diff --git a/tools/capone/Jamfile b/tools/capone/Jamfile deleted file mode 100644 index 41b5c40..0000000 --- a/tools/capone/Jamfile +++ /dev/null @@ -1,13 +0,0 @@ -# -# $Id$ -# -# Part of Equinox Desktop Environment (EDE). -# Copyright (c) 2008 EDE Authors. -# -# This program is licenced under terms of the -# GNU General Public Licence version 2 or newer. -# See COPYING for details. - -SubDir TOP tools capone ; - -SubInclude TOP tools capone src ; diff --git a/tools/capone/lib/capone.init b/tools/capone/lib/capone.init deleted file mode 100644 index df0d5eb..0000000 --- a/tools/capone/lib/capone.init +++ /dev/null @@ -1,602 +0,0 @@ -;; vim:set ft=scheme: -;; Initialization file for TinySCHEME 1.39 - -; Per R5RS, up to four deep compositions should be defined -(define (caar x) (car (car x))) -(define (cadr x) (car (cdr x))) -(define (cdar x) (cdr (car x))) -(define (cddr x) (cdr (cdr x))) -(define (caaar x) (car (car (car x)))) -(define (caadr x) (car (car (cdr x)))) -(define (cadar x) (car (cdr (car x)))) -(define (caddr x) (car (cdr (cdr x)))) -(define (cdaar x) (cdr (car (car x)))) -(define (cdadr x) (cdr (car (cdr x)))) -(define (cddar x) (cdr (cdr (car x)))) -(define (cdddr x) (cdr (cdr (cdr x)))) -(define (caaaar x) (car (car (car (car x))))) -(define (caaadr x) (car (car (car (cdr x))))) -(define (caadar x) (car (car (cdr (car x))))) -(define (caaddr x) (car (car (cdr (cdr x))))) -(define (cadaar x) (car (cdr (car (car x))))) -(define (cadadr x) (car (cdr (car (cdr x))))) -(define (caddar x) (car (cdr (cdr (car x))))) -(define (cadddr x) (car (cdr (cdr (cdr x))))) -(define (cdaaar x) (cdr (car (car (car x))))) -(define (cdaadr x) (cdr (car (car (cdr x))))) -(define (cdadar x) (cdr (car (cdr (car x))))) -(define (cdaddr x) (cdr (car (cdr (cdr x))))) -(define (cddaar x) (cdr (cdr (car (car x))))) -(define (cddadr x) (cdr (cdr (car (cdr x))))) -(define (cdddar x) (cdr (cdr (cdr (car x))))) -(define (cddddr x) (cdr (cdr (cdr (cdr x))))) - -(macro (unless form) - `(if (not ,(cadr form)) (begin ,@(cddr form)))) - -(macro (when form) - `(if ,(cadr form) (begin ,@(cddr form)))) - -; DEFINE-MACRO Contributed by Andy Gaynor -(macro (define-macro dform) - (if (symbol? (cadr dform)) - `(macro ,@(cdr dform)) - (let ((form (gensym))) - `(macro (,(caadr dform) ,form) - (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) - -; Utilities for math. Notice that inexact->exact is primitive, -; but exact->inexact is not. -(define exact? integer?) -(define (inexact? x) (and (real? x) (not (integer? x)))) -(define (even? n) (= (remainder n 2) 0)) -(define (odd? n) (not (= (remainder n 2) 0))) -(define (zero? n) (= n 0)) -(define (positive? n) (> n 0)) -(define (negative? n) (< n 0)) -(define complex? number?) -(define rational? real?) -(define (abs n) (if (>= n 0) n (- n))) -(define (exact->inexact n) (* n 1.0)) -(define (<> n1 n2) (not (= n1 n2))) -(define (max . lst) - (foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst))) -(define (min . lst) - (foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst))) -(define (succ x) (+ x 1)) -(define (pred x) (- x 1)) -(define (gcd a b) - (let ((aa (abs a)) - (bb (abs b))) - (if (= bb 0) - aa - (gcd bb (remainder aa bb))))) -(define (lcm a b) - (if (or (= a 0) (= b 0)) - 0 - (abs (* (quotient a (gcd a b)) b)))) - -(define call/cc call-with-current-continuation) - -(define (string . charlist) - (list->string charlist)) - -(define (list->string charlist) - (let* ((len (length charlist)) - (newstr (make-string len)) - (fill-string! - (lambda (str i len charlist) - (if (= i len) - str - (begin (string-set! str i (car charlist)) - (fill-string! str (+ i 1) len (cdr charlist))))))) - (fill-string! newstr 0 len charlist))) - -(define (string-fill! s e) - (let ((n (string-length s))) - (let loop ((i 0)) - (if (= i n) - s - (begin (string-set! s i e) (loop (succ i))))))) - -(define (string->list s) - (let loop ((n (pred (string-length s))) (l '())) - (if (= n -1) - l - (loop (pred n) (cons (string-ref s n) l))))) - -(define (string-copy str) - (string-append str)) - -(define (string->anyatom str pred) - (let* ((a (string->atom str))) - (if (pred a) a - (error "string->xxx: not a xxx" a)))) - -(define (string->number str) (string->anyatom str number?)) - -(define (anyatom->string n pred) - (if (pred n) - (atom->string n) - (error "xxx->string: not a xxx" n))) - - -(define (number->string n) (anyatom->string n number?)) - -(define (char-cmp? cmp a b) - (cmp (char->integer a) (char->integer b))) -(define (char-ci-cmp? cmp a b) - (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b)))) - -(define (char=? a b) (char-cmp? = a b)) -(define (char? a b) (char-cmp? > a b)) -(define (char<=? a b) (char-cmp? <= a b)) -(define (char>=? a b) (char-cmp? >= a b)) - -(define (char-ci=? a b) (char-ci-cmp? = a b)) -(define (char-ci? a b) (char-ci-cmp? > a b)) -(define (char-ci<=? a b) (char-ci-cmp? <= a b)) -(define (char-ci>=? a b) (char-ci-cmp? >= a b)) - -; Note the trick of returning (cmp x y) -(define (string-cmp? chcmp cmp a b) - (let ((na (string-length a)) (nb (string-length b))) - (let loop ((i 0)) - (cond - ((= i na) - (if (= i nb) (cmp 0 0) (cmp 0 1))) - ((= i nb) - (cmp 1 0)) - ((chcmp = (string-ref a i) (string-ref b i)) - (loop (succ i))) - (else - (chcmp cmp (string-ref a i) (string-ref b i))))))) - - -(define (string=? a b) (string-cmp? char-cmp? = a b)) -(define (string? a b) (string-cmp? char-cmp? > a b)) -(define (string<=? a b) (string-cmp? char-cmp? <= a b)) -(define (string>=? a b) (string-cmp? char-cmp? >= a b)) - -(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b)) -(define (string-ci? a b) (string-cmp? char-ci-cmp? > a b)) -(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b)) -(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b)) - -(define (list . x) x) - -(define (foldr f x lst) - (if (null? lst) - x - (foldr f (f x (car lst)) (cdr lst)))) - -(define (unzip1-with-cdr . lists) - (unzip1-with-cdr-iterative lists '() '())) - -(define (unzip1-with-cdr-iterative lists cars cdrs) - (if (null? lists) - (cons cars cdrs) - (let ((car1 (caar lists)) - (cdr1 (cdar lists))) - (unzip1-with-cdr-iterative - (cdr lists) - (append cars (list car1)) - (append cdrs (list cdr1)))))) - -;; -;; Original implementation that pretty sucks -;; -;(define (map proc . lists) -; (if (null? lists) -; (apply proc) -; (if (null? (car lists)) -; '() -; (let* ((unz (apply unzip1-with-cdr lists)) -; (cars (car unz)) -; (cdrs (cdr unz))) -; (cons (apply proc cars) (apply map (cons proc cdrs))))))) - -(define (map1 proc lst) - (if (null? lst) - lst - (let loop ((lst lst) - (nls '())) - (if (null? lst) - (reverse nls) - (loop (cdr lst) - (cons (proc (car lst)) nls)))))) - -(define (map proc lst . more) - (if (null? more) - (map1 proc lst) - (let map-more ((lst lst) - (more more)) - (if (null? lst) - lst - (cons (apply proc (car lst) (map car more)) - (map-more (cdr lst) - (map cdr more))))))) - -;; -;; Original implementation that pretty sucks -;; Althought it behaves as given in Dybvig's book, PLT and chicken -;; versions does not allow multiple list arguments -;; -;(define (for-each proc . lists) -; (if (null? lists) -; (apply proc) -; (if (null? (car lists)) -; #t -; (let* ((unz (apply unzip1-with-cdr lists)) -; (cars (car unz)) -; (cdrs (cdr unz))) -; (apply proc cars) (apply map (cons proc cdrs)))))) - -(define (for-each proc lst) - (if (not (null? lst)) - (begin - (proc (car lst)) - (for-each proc (cdr lst))))) - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1)))) - -(define (list-ref x k) - (car (list-tail x k))) - -(define (last-pair x) - (if (pair? (cdr x)) - (last-pair (cdr x)) - x)) - -(define (head stream) (car stream)) - -(define (tail stream) (force (cdr stream))) - -(define (vector-equal? x y) - (and (vector? x) (vector? y) (= (vector-length x) (vector-length y)) - (let ((n (vector-length x))) - (let loop ((i 0)) - (if (= i n) - #t - (and (equal? (vector-ref x i) (vector-ref y i)) - (loop (succ i)))))))) - -(define (list->vector x) - (apply vector x)) - -(define (vector-fill! v e) - (let ((n (vector-length v))) - (let loop ((i 0)) - (if (= i n) - v - (begin (vector-set! v i e) (loop (succ i))))))) - -(define (vector->list v) - (let loop ((n (pred (vector-length v))) (l '())) - (if (= n -1) - l - (loop (pred n) (cons (vector-ref v n) l))))) - -;; The following quasiquote macro is due to Eric S. Tiedemann. -;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. -;; -;; Subsequently modified to handle vectors: D. Souflis - -(macro - quasiquote - (lambda (l) - (define (mcons f l r) - (if (and (pair? r) - (eq? (car r) 'quote) - (eq? (car (cdr r)) (cdr f)) - (pair? l) - (eq? (car l) 'quote) - (eq? (car (cdr l)) (car f))) - (if (or (procedure? f) (number? f) (string? f)) - f - (list 'quote f)) - (if (eqv? l vector) - (apply l (eval r)) - (list 'cons l r) - ))) - (define (mappend f l r) - (if (or (null? (cdr f)) - (and (pair? r) - (eq? (car r) 'quote) - (eq? (car (cdr r)) '()))) - l - (list 'append l r))) - (define (foo level form) - (cond ((not (pair? form)) - (if (or (procedure? form) (number? form) (string? form)) - form - (list 'quote form)) - ) - ((eq? 'quasiquote (car form)) - (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) - (#t (if (zero? level) - (cond ((eq? (car form) 'unquote) (car (cdr form))) - ((eq? (car form) 'unquote-splicing) - (error "Unquote-splicing wasn't in a list:" - form)) - ((and (pair? (car form)) - (eq? (car (car form)) 'unquote-splicing)) - (mappend form (car (cdr (car form))) - (foo level (cdr form)))) - (#t (mcons form (foo level (car form)) - (foo level (cdr form))))) - (cond ((eq? (car form) 'unquote) - (mcons form ''unquote (foo (- level 1) - (cdr form)))) - ((eq? (car form) 'unquote-splicing) - (mcons form ''unquote-splicing - (foo (- level 1) (cdr form)))) - (#t (mcons form (foo level (car form)) - (foo level (cdr form))))))))) - (foo 0 (car (cdr l))))) - - -;;;;; atom? and equal? written by a.k - -;;;; atom? -(define (atom? x) - (not (pair? x))) - -;;;; equal? -(define (equal? x y) - (cond - ((pair? x) - (and (pair? y) - (equal? (car x) (car y)) - (equal? (cdr x) (cdr y)))) - ((vector? x) - (and (vector? y) (vector-equal? x y))) - ((string? x) - (and (string? y) (string=? x y))) - (else (eqv? x y)))) - -;;;; (do ((var init inc) ...) (endtest result ...) body ...) -;; -(macro do - (lambda (do-macro) - (apply (lambda (do vars endtest . body) - (let ((do-loop (gensym))) - `(letrec ((,do-loop - (lambda ,(map (lambda (x) - (if (pair? x) (car x) x)) - `,vars) - (if ,(car endtest) - (begin ,@(cdr endtest)) - (begin - ,@body - (,do-loop - ,@(map (lambda (x) - (cond - ((not (pair? x)) x) - ((< (length x) 3) (car x)) - (else (car (cdr (cdr x)))))) - `,vars))))))) - (,do-loop - ,@(map (lambda (x) - (if (and (pair? x) (cdr x)) - (car (cdr x)) - '())) - `,vars))))) - do-macro))) - -;;;; generic-member -(define (generic-member cmp obj lst) - (cond - ((null? lst) #f) - ((cmp obj (car lst)) lst) - (else (generic-member cmp obj (cdr lst))))) - -(define (memq obj lst) - (generic-member eq? obj lst)) -(define (memv obj lst) - (generic-member eqv? obj lst)) -(define (member obj lst) - (generic-member equal? obj lst)) - -;;;; generic-assoc -(define (generic-assoc cmp obj alst) - (cond - ((null? alst) #f) - ((cmp obj (caar alst)) (car alst)) - (else (generic-assoc cmp obj (cdr alst))))) - -(define (assq obj alst) - (generic-assoc eq? obj alst)) -(define (assv obj alst) - (generic-assoc eqv? obj alst)) -(define (assoc obj alst) - (generic-assoc equal? obj alst)) - -(define (acons x y z) (cons (cons x y) z)) - -;;;; Utility to ease macro creation -(define (macro-expand form) - ((eval (get-closure-code (eval (car form)))) form)) - -;;;; Handy for imperative programs -;;;; Used as: (define-with-return (foo x y) .... (return z) ...) -(macro (define-with-return form) - `(define ,(cadr form) - (call/cc (lambda (return) ,@(cddr form))))) - -;;;; Simple exception handling -; -; Exceptions are caught as follows: -; -; (catch (do-something to-recover and-return meaningful-value) -; (if-something goes-wrong) -; (with-these calls)) -; -; "Catch" establishes a scope spanning multiple call-frames -; until another "catch" is encountered. -; -; Exceptions are thrown with: -; -; (throw "message") -; -; If used outside a (catch ...), reverts to (error "message) - -(define *handlers* (list)) - -(define (push-handler proc) - (set! *handlers* (cons proc *handlers*))) - -(define (pop-handler) - (let ((h (car *handlers*))) - (set! *handlers* (cdr *handlers*)) - h)) - -(define (more-handlers?) - (pair? *handlers*)) - -(define (throw . x) - (if (more-handlers?) - (apply (pop-handler)) - (apply error x))) - -(macro (catch form) - (let ((label (gensym))) - `(call/cc (lambda (exit) - (push-handler (lambda () (exit ,(cadr form)))) - (let ((,label (begin ,@(cddr form)))) - (pop-handler) - ,label))))) - -(define *error-hook* throw) - - -;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL - -(macro (make-environment form) - `(apply (lambda () - ,@(cdr form) - (current-environment)))) - -(define-macro (eval-polymorphic x . envl) - (display envl) - (let* ((env (if (null? envl) (current-environment) (eval (car envl)))) - (xval (eval x env))) - (if (closure? xval) - (make-closure (get-closure-code xval) env) - xval))) - -; Redefine this if you install another package infrastructure -; Also redefine 'package' -(define *colon-hook* eval) - -;;;;; I/O - -(define (input-output-port? p) - (and (input-port? p) (output-port? p))) - -(define (close-port p) - (cond - ((input-output-port? p) (close-input-port (close-output-port p))) - ((input-port? p) (close-input-port p)) - ((output-port? p) (close-output-port p)) - (else (throw "Not a port" p)))) - -(define (call-with-input-file s p) - (let ((inport (open-input-file s))) - (if (eq? inport #f) - #f - (let ((res (p inport))) - (close-input-port inport) - res)))) - -(define (call-with-output-file s p) - (let ((outport (open-output-file s))) - (if (eq? outport #f) - #f - (let ((res (p outport))) - (close-output-port outport) - res)))) - -(define (with-input-from-file s p) - (let ((inport (open-input-file s))) - (if (eq? inport #f) - #f - (let ((prev-inport (current-input-port))) - (set-input-port inport) - (let ((res (p))) - (close-input-port inport) - (set-input-port prev-inport) - res))))) - -(define (with-output-to-file s p) - (let ((outport (open-output-file s))) - (if (eq? outport #f) - #f - (let ((prev-outport (current-output-port))) - (set-output-port outport) - (let ((res (p))) - (close-output-port outport) - (set-output-port prev-outport) - res))))) - -(define (with-input-output-from-to-files si so p) - (let ((inport (open-input-file si)) - (outport (open-input-file so))) - (if (not (and inport outport)) - (begin - (close-input-port inport) - (close-output-port outport) - #f) - (let ((prev-inport (current-input-port)) - (prev-outport (current-output-port))) - (set-input-port inport) - (set-output-port outport) - (let ((res (p))) - (close-input-port inport) - (close-output-port outport) - (set-input-port prev-inport) - (set-output-port prev-outport) - res))))) - -;; SRFI-0 -;; COND-EXPAND -;; Implemented as a macro -(define *features* '(srfi-0)) - -(define-macro (cond-expand . cond-action-list) - (cond-expand-runtime cond-action-list)) - -(define (cond-expand-runtime cond-action-list) - (if (null? cond-action-list) - #t - (if (cond-eval (caar cond-action-list)) - `(begin ,@(cdar cond-action-list)) - (cond-expand-runtime (cdr cond-action-list))))) - -(define (cond-eval-and cond-list) - (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list)) - -(define (cond-eval-or cond-list) - (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list)) - -(define (cond-eval condition) - (cond ((symbol? condition) - (if (member condition *features*) #t #f)) - ((eq? condition #t) #t) - ((eq? condition #f) #f) - (else (case (car condition) - ((and) (cond-eval-and (cdr condition))) - ((or) (cond-eval-or (cdr condition))) - ((not) (if (not (null? (cddr condition))) - (error "cond-expand : 'not' takes 1 argument") - (not (cond-eval (cadr condition))))) - (else (error "cond-expand : unknown operator" (car condition))))))) - -(gc-verbose #f) diff --git a/tools/capone/lib/common.ss b/tools/capone/lib/common.ss deleted file mode 100644 index 8700c01..0000000 --- a/tools/capone/lib/common.ss +++ /dev/null @@ -1,182 +0,0 @@ -;; -;; common functions for capone -;; - -(define first car) -(define rest cdr) - -;; inc/dec family -(define (inc n) - (+ 1 n)) - -(define (dec n) - (- n 1)) - -(define-macro (inc! n) - `(set! ,n (+ 1 ,n))) - -(define-macro (dec! n) - `(set! ,n (- ,n 1))) - -(define-macro (if-not . body) - `(if (not ,(car body)) - ,@(cdr body))) - -(define-macro (var v val) - `(define ,v ,val)) - -;; -;; Allow defining functions like: -;; (def name (param1 param2) -;; ... -;; ) -(define-macro (def name . rest) - ;; name - function name - ;; (car rest) - function params - ;; (cdr rest)- function body - `(define ,(cons name (car rest)) - ,@(cdr rest))) - -;; -;; Flexible printing e.g.: -;; (define num 3) -;; (print "This number is: " num "\n") -;; -(define (print arg . rest) - (display arg) - (let loop ((rest rest)) - (if (not (null? rest)) - (begin - (display (car rest)) - (loop (cdr rest)))))) - -;; -;; (print) with newline -;; -(define-macro (println . body) - `(print ,@body "\n")) - -;; -;; while loop macro; used like: -;; (while (> a 2) -;; ... -;; ) -;; -(define-macro (while . body) - `(let loop () - ;; fetch condition - (if ,(car body) - (begin - ;; evaluate body - ,@(cdr body) - (loop))))) - -;; -;; A python-like 'for' loop, works only on lists, like: -;; (for i in '(1 2 3 4 5) -;; (print "Number is " i "\n") -;; ) -(define-macro (for . expr) - ;; (car expr) is 'i' - ;; (caddr expr) is list - ;; (cdddr expr) is body - (let* (( lst (gensym) )) - `(let (( ,lst ,(caddr expr) )) - (cond - ((list? ,lst) - (map (lambda (,(car expr)) - ,@(cdddr expr)) - ,lst)) - (else - (throw "Unsupported type in 'for' loop")))))) - -;; -;; Split a list to a list of pairs so we can easily -;; embed it in 'let' expression via 'slet' macro -;; e.g. (1 2 3 4) => ((1 2) (3 4)) -;; -(define (explode-list lst) - (let loop ((lst lst) - (n '())) - (if (null? lst) - (reverse n) - (begin - ;; huh... - (set! n (cons (list (car lst) (cadr lst)) n)) - (loop (cddr lst) n) -)))) - -;; -;; slet or 'simplified let' is a 'let' with little less bracess -;; e.g. (let (a 1 b 2) body) -;; -(define-macro (slet . body) - `(let ,@(list (explode-list (car body))) - ,@(cdr body) -)) - -(define-macro (slet* . body) - `(let* ,@(list (explode-list (car body))) - ,@(cdr body) -)) - -;; -;; range function; returns a list of numbers in form [start end) -;; -;; Althought we could wrote this function cleanly without decrementors -;; using recursion call after 'cons', we would loose tail call optimization -;; yielding much slower function. -;; -(define (range start end) - (let loop ((s (- start 1)) - (e (- end 1)) - (lst '())) - (if (>= s e) - lst - (loop s (- e 1) (cons e lst))))) - -;; -;; iota function; returns a list of numbers -;; -(define (iota n) - (range 0 n)) - -;; -;; Inplace vector shuffle via Fisher-Yates algorithm -;; -(define (shuffle-vector! v) - (let ((i (vector-length v)) - (k 0) - (tmp 0)) - (while (> i 1) - (set! k (modulo (random-next) i)) - (dec! i) - (set! tmp (vector-ref v i)) - (vector-set! v i (vector-ref v k)) - (vector-set! v k tmp) -))) - -;; -;; function for easier timing -;; -(define (timeit proc) - (let ((v1 0) - (v2 0)) - - (set! v1 (clock)) - (proc) - (set! v2 (clock)) - ;; 1000000 is value of CLOCKS_PER_SEC - (/ (- v2 v1) 1000000))) - -(define *timeit-start-value* 0) -(define *timeit-end-value* 0) - -(define (timeit-start) - (set! *timeit-start-value* (clock))) - -(define (timeit-end) - (set! *timeit-end-value* (clock))) - -(define (timeit-result) - (/ (- *timeit-end-value* *timeit-start-value*) 1000000)) diff --git a/tools/capone/src/Jamfile b/tools/capone/src/Jamfile deleted file mode 100644 index c0f7d5d..0000000 --- a/tools/capone/src/Jamfile +++ /dev/null @@ -1,28 +0,0 @@ -# -# $Id$ -# -# Part of Equinox Desktop Environment (EDE). -# Copyright (c) 2008 EDE Authors. -# -# This program is licenced under terms of the -# GNU General Public Licence version 2 or newer. -# See COPYING for details. - -SubDir TOP tools capone src ; - -PCRE_SRC = pcre/pcre.c ; -ObjectCcFlags $(PCRE_SRC) : $(GLOBALFLAGS) ; -Library $(SUBDIR)/pcre/libpcre : $(PCRE_SRC) ; - -SCHEME_SRC = scheme.c dynload.c ; -ObjectCcFlags $(SCHEME_SRC) : -DUSE_STRLWR=1 -DUSE_DL=1 -DUSE_MATH=1 -DUSE_ASCII_NAMES=0 -DINLINE=inline ; - -CAPONE_SRC = capone.cpp $(SCHEME_SRC) dbus.cpp re.cpp sys.cpp ; - -#ObjectC++Flags $(CAPONE_SRC) : -pg ; -#ObjectCcFlags $(CAPONE_SRC) : -g3 -pg ; - -EdeProgram capone : $(CAPONE_SRC) ; -LinkAgainst capone : -Lpcre -lpcre -ledelib_dbus -ldbus-1 -ledelib -lfltk -ldl -lm -lXext -lXft -lX11 ; - -#LINKFLAGS on capone = [ on capone return $(LINKFLAGS) ] -pg ; diff --git a/tools/capone/src/bbb.ss b/tools/capone/src/bbb.ss deleted file mode 100644 index 6c6030b..0000000 --- a/tools/capone/src/bbb.ss +++ /dev/null @@ -1,56 +0,0 @@ -(load "../lib/common.ss") - -(define (map2 proc lst) - (if (null? lst) - lst - (let loop ((lst lst) - (nls '())) - (if (null? lst) - (reverse nls) - (loop (cdr lst) - (cons (proc (car lst)) nls)))))) - -(define (map3 proc lst . more) - (if (null? more) - (map2 proc lst) - (let map-more ((lst lst) - (more more)) - (if (null? lst) - lst - (cons (apply proc (car lst) (map3 car more)) - (map-more (cdr lst) - (map3 cdr more))))))) - -(define lst (iota 3000)) - -(print "Working my map... ") -;; my map -(timeit-start) -(map3 - (fn (x) - (+ 1 x)) lst) -(timeit-end) -(println (timeit-result) " ms") - -(print "Working with builtin map... ") -;; real map -(timeit-start) -(map - (fn (x) - (+ 1 x)) lst) -(timeit-end) -(println (timeit-result) " ms") - -(print "Working my map [2]... ") -;; my map -(timeit-start) -(map3 + lst lst lst) -(timeit-end) -(println (timeit-result) " ms") - -(print "Working with builtin map [2]... ") -;; real map -(timeit-start) -(map + lst lst lst) -(timeit-end) -(println (timeit-result) " ms") diff --git a/tools/capone/src/capone-doc b/tools/capone/src/capone-doc deleted file mode 100755 index c370daf..0000000 --- a/tools/capone/src/capone-doc +++ /dev/null @@ -1,141 +0,0 @@ -#!/usr/bin/env perl -# A tool to generate some html-ized documentation -# based on capone source... see it as doxygen for capone. - -sub write_prolog { - print < - - - -$_[0] - - - -
-EOL -} - -sub write_epilog { - print < - - - -EOL -} - -sub main { - if(@ARGV eq 0) { - print "Usage: capone-doc [FILE] [TITLE]\n"; - print "Generate html-ized documentation by extracting documentation\n"; - print "specific tags on the specific manner from capone source file\n"; - return; - } - - $in_block = 0; - $filename = $ARGV[0]; - - if($ARGV[1]) { - $title = $ARGV[1]; - } else { - $title = $filename . " documentation"; - } - - open(INFILE, $filename) or die "Can't open $filename: $!"; - - &write_prolog($title); - - while() { - # find markers - if(/^;;=/) { - if($in_block eq 0) { - print "
\n"; - $in_block = 1; - } else { - print "
\n"; - print "
\n"; - $in_block = 0; - } - - # strip them - s/;;=(.*)$//; - } - - if($in_block eq 1) { - # strip comments - s/;;\s*\n$/
\n/; - s/;;//; - - # \code and \endcode - s/\\code/
Example:<\/h5>\n
/;
-			s/\\endcode/ <\/pre>/;
-
-			# \func
-			s/\\func (.*)/ 
$1<\/h5>/; - - # \param - s/\\param (.*)/ parameter:<\/b> $1
/; - - # \return - s/\\return (.*)/ returns:<\/b> $1
/; - - # \syntax - s/\\syntax (.*)/ syntax:<\/b> $1<\/i>
/; - - # \br - s/\\br/
/g; - - # \center - s/\\center (.*)$/
$1<\/center>/; - - # grok everything out - print $_; - } - } - - &write_epilog; -} - -&main; diff --git a/tools/capone/src/capone.cpp b/tools/capone/src/capone.cpp deleted file mode 100644 index be50da4..0000000 --- a/tools/capone/src/capone.cpp +++ /dev/null @@ -1,158 +0,0 @@ -#include -#include - -extern "C" { -#include "scheme.h" -#include "scheme-private.h" -#include "dynload.h" -} - -#include "dbus.h" -#include "re.h" -#include "sys.h" - -#define VERSION "0.1" -#define BASE_FILE "capone.init" -#define CHECK_ARGV(argv, pshort, plong) ((strcmp(argv, pshort) == 0) || (strcmp(argv, plong) == 0)) - -extern pointer reverse_in_place(scheme *sc, pointer term, pointer list); - -const char* next_param(int curr, char** argv, int argc) { - int j = curr + 1; - if(j >= argc) - return NULL; - if(argv[j][0] == '-') - return NULL; - return argv[j]; -} - -void help(void) { - puts("Usage: capone [OPTIONS] [FILE]\n"); - puts("Options:"); - puts(" -h, --help Show this help"); - puts(" -v, --version Show version"); - puts(" -d, --lib-dir [dir] Directory with startup libraries"); - puts(" -e, --eval [str] Evaluate given expression\n"); -} - -void register_args_var(scheme* sc, int argc, char** argv) { - pointer args = sc->NIL; - for(int i = 0; i < argc; i++) { - pointer v = mk_string(sc, argv[i]); - args = cons(sc, v, args); - } - - args = reverse_in_place(sc, sc->NIL, args); - scheme_define(sc, - sc->global_env, - mk_symbol(sc, "*args*"), - args); -} - -void do_file_or_expr(FILE* f, const char* expr, const char* dir, int argc, char** argv) { - scheme sc; - if(!scheme_init(&sc)) { - puts("Unable to load interpreter!"); - return; - } - - scheme_set_input_port_file(&sc, stdin); - scheme_set_output_port_file(&sc, stdout); - - char path[256]; - snprintf(path, sizeof(path), "%s/" BASE_FILE, dir); - - FILE* init = fopen(path, "r"); - if(!init) { - printf("\n\nCan't load startup from %s\n", path); - scheme_deinit(&sc); - return; - } - - scheme_load_file(&sc, init); - if(sc.retcode != 0) - puts("Errors in " BASE_FILE); - - - /* define 'load-extension' function first */ - scheme_define(&sc, sc.global_env, mk_symbol(&sc,"load-extension"), mk_foreign_func(&sc, scm_load_ext)); - - register_args_var(&sc, argc, argv); - - register_dbus_functions(&sc); - register_re_functions(&sc); - register_sys_functions(&sc); - - if(f) { - scheme_load_file(&sc, f); - if(sc.retcode != 0 && sc.interactive_repl != 1) - puts("*** Errors in source file"); - } - - if(expr) { - scheme_load_string(&sc, expr); - if(sc.retcode != 0) - printf("*** Bad expression '%s'\n", expr); - } - - scheme_deinit(&sc); -} - -int main(int argc, char** argv) { - const char* a, *l, *filename, *expr; - l = "../lib"; - filename = NULL; - expr = NULL; - - for(int i = 1; i < argc; i++) { - a = argv[i]; - if(a[0] == '-') { - if(CHECK_ARGV(a, "-h", "--help")) { - help(); - return 0; - } else if(CHECK_ARGV(a, "-v", "--version")) { - puts(VERSION); - return 0; - } else if(CHECK_ARGV(a, "-d", "--lib-dir")) { - l = next_param(i, argv, argc); - if(!l) { - puts("Missing directory parameter"); - return 1; - } - i++; - } else if(CHECK_ARGV(a, "-e", "--eval")) { - expr = next_param(i, argv, argc); - if(!expr) { - puts("Missing expression"); - return 1; - } - i++; - } else { - printf("Unknown '%s' parameter. Run capone -h for more options\n", a); - return 1; - } - } else { - filename = a; - break; - } - } - - if(expr) { - do_file_or_expr(NULL, expr, l, argc, argv); - } else if(filename) { - FILE* f = fopen(filename, "r"); - if(!f) { - printf("Unable to open '%s'!\n", filename); - return 1; - } - - do_file_or_expr(f, NULL, l, argc, argv); - fclose(f); - } else { - printf("capone " VERSION " (based on tinyscheme 1.39)\n"); - printf("Type \"(quit)\" or press Ctrl-C to exit interpreter when you are done."); - do_file_or_expr(stdin, NULL, l, argc, argv); - } - - return 0; -} diff --git a/tools/capone/src/dbus.cpp b/tools/capone/src/dbus.cpp deleted file mode 100644 index c4c0cd7..0000000 --- a/tools/capone/src/dbus.cpp +++ /dev/null @@ -1,90 +0,0 @@ -#include -#include -#include - -extern "C" { -#define USE_INTERFACE 1 - -#include "scheme-private.h" -#include "scheme.h" -} - -#include "dbus.h" - -using namespace edelib; - -/* next types in scheme_types in 'scheme.cpp' */ -/* -#define T_DBUS_CONNECTION 15 -#define T_DBUS_MESSAGE 16 -*/ - -/* (dbus-send <"system|session"> */ -static pointer dbus_send(scheme* sc, pointer args) { - if(args == sc->NIL) - return sc->F; - - pointer a; - const char* service, *interface, *path; - bool is_system = false; - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - service = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - interface = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - path = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - - const char* sv = sc->vptr->string_value(a); - if(strcmp(sv, "system") == 0) - is_system = true; - - EdbusConnection c; - bool ret; - if(is_system) - ret = c.connect(EDBUS_SYSTEM); - else - ret = c.connect(EDBUS_SESSION); - if(!ret) - return sc->F; - - args = sc->vptr->pair_cdr(args); - - EdbusMessage msg; - msg.create_signal(path, interface, service); - - if(sc->vptr->is_number(a)) - msg << EdbusData::from_int32(sc->vptr->ivalue(a)); - else if(sc->vptr->is_string(a)) - msg << EdbusData::from_string(sc->vptr->string_value(a)); - else - return sc->F; - - return c.send(msg) ? sc->T : sc->F; -} - -void register_dbus_functions(scheme* sc) { - sc->vptr->scheme_define( - sc, - sc->global_env, - sc->vptr->mk_symbol(sc, "dbus-send"), - sc->vptr->mk_foreign_func(sc, dbus_send)); -} diff --git a/tools/capone/src/dbus.h b/tools/capone/src/dbus.h deleted file mode 100644 index 79c8445..0000000 --- a/tools/capone/src/dbus.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef __DBUS_H__ -#define __DBUS_H__ - -void register_dbus_functions(scheme* sc); - -#endif diff --git a/tools/capone/src/dynload.c b/tools/capone/src/dynload.c deleted file mode 100644 index 50e0560..0000000 --- a/tools/capone/src/dynload.c +++ /dev/null @@ -1,139 +0,0 @@ -/* dynload.c Dynamic Loader for TinyScheme */ -/* Original Copyright (c) 1999 Alexander Shendi */ -/* Modifications for NT and dl_* interface, scm_load_ext: D. Souflis */ -/* Refurbished by Stephen Gildea */ - -#define _SCHEME_SOURCE -#include "dynload.h" -#include -#include -#include - -#ifndef MAXPATHLEN -# define MAXPATHLEN 1024 -#endif - -static void make_filename(const char *name, char *filename); -static void make_init_fn(const char *name, char *init_fn); - -#ifdef _WIN32 -# include -#else -typedef void *HMODULE; -typedef void (*FARPROC)(); -#define SUN_DL -#include -#endif - -#ifdef _WIN32 - -#define PREFIX "" -#define SUFFIX ".dll" - - static void display_w32_error_msg(const char *additional_message) - { - LPVOID msg_buf; - - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, - NULL, GetLastError(), 0, - (LPTSTR)&msg_buf, 0, NULL); - fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf); - LocalFree(msg_buf); - } - -static HMODULE dl_attach(const char *module) { - HMODULE dll = LoadLibrary(module); - if (!dll) display_w32_error_msg(module); - return dll; -} - -static FARPROC dl_proc(HMODULE mo, const char *proc) { - FARPROC procedure = GetProcAddress(mo,proc); - if (!procedure) display_w32_error_msg(proc); - return procedure; -} - -static void dl_detach(HMODULE mo) { - (void)FreeLibrary(mo); -} - -#elif defined(SUN_DL) - -#include - -#define PREFIX "lib" -#define SUFFIX ".so" - -static HMODULE dl_attach(const char *module) { - HMODULE so=dlopen(module,RTLD_LAZY); - if(!so) { - fprintf(stderr, "Error loading scheme extension \"%s\": %s\n", module, dlerror()); - } - return so; -} - -static FARPROC dl_proc(HMODULE mo, const char *proc) { - const char *errmsg; - FARPROC fp=(FARPROC)dlsym(mo,proc); - if ((errmsg = dlerror()) == 0) { - return fp; - } - fprintf(stderr, "Error initializing scheme module \"%s\": %s\n", proc, errmsg); - return 0; -} - -static void dl_detach(HMODULE mo) { - (void)dlclose(mo); -} -#endif - -pointer scm_load_ext(scheme *sc, pointer args) -{ - pointer first_arg; - pointer retval; - char filename[MAXPATHLEN], init_fn[MAXPATHLEN+6]; - char *name; - HMODULE dll_handle; - void (*module_init)(scheme *sc); - - if ((args != sc->NIL) && is_string((first_arg = pair_car(args)))) { - name = string_value(first_arg); - make_filename(name,filename); - make_init_fn(name,init_fn); - dll_handle = dl_attach(filename); - if (dll_handle == 0) { - retval = sc -> F; - } - else { - module_init = (void(*)(scheme *))dl_proc(dll_handle, init_fn); - if (module_init != 0) { - (*module_init)(sc); - retval = sc -> T; - } - else { - retval = sc->F; - } - } - } - else { - retval = sc -> F; - } - - return(retval); -} - -static void make_filename(const char *name, char *filename) { - strcpy(filename,name); - strcat(filename,SUFFIX); -} - -static void make_init_fn(const char *name, char *init_fn) { - const char *p=strrchr(name,'/'); - if(p==0) { - p=name; - } else { - p++; - } - strcpy(init_fn,"init_"); - strcat(init_fn,p); -} diff --git a/tools/capone/src/dynload.h b/tools/capone/src/dynload.h deleted file mode 100644 index 069dae3..0000000 --- a/tools/capone/src/dynload.h +++ /dev/null @@ -1,12 +0,0 @@ -/* dynload.h */ -/* Original Copyright (c) 1999 Alexander Shendi */ -/* Modifications for NT and dl_* interface: D. Souflis */ - -#ifndef DYNLOAD_H -#define DYNLOAD_H - -#include "scheme-private.h" - -SCHEME_EXPORT pointer scm_load_ext(scheme *sc, pointer arglist); - -#endif diff --git a/tools/capone/src/foo.ss b/tools/capone/src/foo.ss deleted file mode 100644 index 367ed7a..0000000 --- a/tools/capone/src/foo.ss +++ /dev/null @@ -1,7 +0,0 @@ - -(define (foo a b) - ;;"Retrun the sum of it's arguments" - (+ a b)) - -(display (foo 3 2)) -(newline) diff --git a/tools/capone/src/opdefines.h b/tools/capone/src/opdefines.h deleted file mode 100644 index 721ba66..0000000 --- a/tools/capone/src/opdefines.h +++ /dev/null @@ -1,192 +0,0 @@ - _OP_DEF(opexe_0, "load", 1, 1, TST_STRING, OP_LOAD ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T0LVL ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T1LVL ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_READ_INTERNAL ) - _OP_DEF(opexe_0, "gensym", 0, 0, 0, OP_GENSYM ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_VALUEPRINT ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_EVAL ) -#if USE_TRACING - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_EVAL ) -#endif - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY ) -#if USE_TRACING - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY ) - _OP_DEF(opexe_0, "tracing", 1, 1, TST_NATURAL, OP_TRACING ) -#endif - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DOMACRO ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA2 ) - _OP_DEF(opexe_0, "make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_QUOTE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF1 ) - _OP_DEF(opexe_0, "defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_BEGIN ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0AST ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1AST ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2AST ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET0REC ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET1REC ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET2REC ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_DELAY ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C0STREAM ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C1STREAM ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE2 ) - _OP_DEF(opexe_1, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) - _OP_DEF(opexe_1, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) - _OP_DEF(opexe_1, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) -#if USE_MATH - _OP_DEF(opexe_2, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) - _OP_DEF(opexe_2, "exp", 1, 1, TST_NUMBER, OP_EXP ) - _OP_DEF(opexe_2, "log", 1, 1, TST_NUMBER, OP_LOG ) - _OP_DEF(opexe_2, "sin", 1, 1, TST_NUMBER, OP_SIN ) - _OP_DEF(opexe_2, "cos", 1, 1, TST_NUMBER, OP_COS ) - _OP_DEF(opexe_2, "tan", 1, 1, TST_NUMBER, OP_TAN ) - _OP_DEF(opexe_2, "asin", 1, 1, TST_NUMBER, OP_ASIN ) - _OP_DEF(opexe_2, "acos", 1, 1, TST_NUMBER, OP_ACOS ) - _OP_DEF(opexe_2, "atan", 1, 2, TST_NUMBER, OP_ATAN ) - _OP_DEF(opexe_2, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) - _OP_DEF(opexe_2, "expt", 2, 2, TST_NUMBER, OP_EXPT ) - _OP_DEF(opexe_2, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) - _OP_DEF(opexe_2, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) - _OP_DEF(opexe_2, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) - _OP_DEF(opexe_2, "round", 1, 1, TST_NUMBER, OP_ROUND ) -#endif - _OP_DEF(opexe_2, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) - _OP_DEF(opexe_2, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) - _OP_DEF(opexe_2, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) - _OP_DEF(opexe_2, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) - _OP_DEF(opexe_2, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) - _OP_DEF(opexe_2, "remainder", 2, 2, TST_INTEGER, OP_REM ) - _OP_DEF(opexe_2, "modulo", 2, 2, TST_INTEGER, OP_MOD ) - _OP_DEF(opexe_2, "car", 1, 1, TST_PAIR, OP_CAR ) - _OP_DEF(opexe_2, "cdr", 1, 1, TST_PAIR, OP_CDR ) - _OP_DEF(opexe_2, "cons", 2, 2, TST_NONE, OP_CONS ) - _OP_DEF(opexe_2, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) - _OP_DEF(opexe_2, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) - _OP_DEF(opexe_2, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) - _OP_DEF(opexe_2, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) - _OP_DEF(opexe_2, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) - _OP_DEF(opexe_2, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) - _OP_DEF(opexe_2, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) - _OP_DEF(opexe_2, "atom->string", 1, 1, TST_ANY, OP_ATOM2STR ) - _OP_DEF(opexe_2, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) - _OP_DEF(opexe_2, "string->atom", 1, 1, TST_STRING, OP_STR2ATOM ) - _OP_DEF(opexe_2, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) - _OP_DEF(opexe_2, "string-length", 1, 1, TST_STRING, OP_STRLEN ) - _OP_DEF(opexe_2, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) - _OP_DEF(opexe_2, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) - _OP_DEF(opexe_2, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) - _OP_DEF(opexe_2, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) - _OP_DEF(opexe_2, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) - _OP_DEF(opexe_2, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) - _OP_DEF(opexe_2, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) - _OP_DEF(opexe_2, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) - _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) - _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) - _OP_DEF(opexe_3, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) - _OP_DEF(opexe_3, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) - _OP_DEF(opexe_3, "null?", 1, 1, TST_NONE, OP_NULLP ) - _OP_DEF(opexe_3, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) - _OP_DEF(opexe_3, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) - _OP_DEF(opexe_3, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) - _OP_DEF(opexe_3, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) - _OP_DEF(opexe_3, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) - _OP_DEF(opexe_3, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) - _OP_DEF(opexe_3, "number?", 1, 1, TST_ANY, OP_NUMBERP ) - _OP_DEF(opexe_3, "string?", 1, 1, TST_ANY, OP_STRINGP ) - _OP_DEF(opexe_3, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) - _OP_DEF(opexe_3, "real?", 1, 1, TST_ANY, OP_REALP ) - _OP_DEF(opexe_3, "char?", 1, 1, TST_ANY, OP_CHARP ) -#if USE_CHAR_CLASSIFIERS - _OP_DEF(opexe_3, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) - _OP_DEF(opexe_3, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) - _OP_DEF(opexe_3, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) - _OP_DEF(opexe_3, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) - _OP_DEF(opexe_3, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) -#endif - _OP_DEF(opexe_3, "port?", 1, 1, TST_ANY, OP_PORTP ) - _OP_DEF(opexe_3, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) - _OP_DEF(opexe_3, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) - _OP_DEF(opexe_3, "procedure?", 1, 1, TST_ANY, OP_PROCP ) - _OP_DEF(opexe_3, "pair?", 1, 1, TST_ANY, OP_PAIRP ) - _OP_DEF(opexe_3, "list?", 1, 1, TST_ANY, OP_LISTP ) - _OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP ) - _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) - _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) - _OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV ) - _OP_DEF(opexe_4, "force", 1, 1, TST_ANY, OP_FORCE ) - _OP_DEF(opexe_4, 0, 0, 0, 0, OP_SAVE_FORCED ) - _OP_DEF(opexe_4, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) - _OP_DEF(opexe_4, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) - _OP_DEF(opexe_4, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) - _OP_DEF(opexe_4, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) - _OP_DEF(opexe_4, "error", 1, INF_ARG, TST_NONE, OP_ERR0 ) - _OP_DEF(opexe_4, 0, 0, 0, 0, OP_ERR1 ) - _OP_DEF(opexe_4, "reverse", 1, 1, TST_PAIR, OP_REVERSE ) - _OP_DEF(opexe_4, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) - _OP_DEF(opexe_4, "append", 0, INF_ARG, TST_NONE, OP_APPEND ) - _OP_DEF(opexe_4, "put", 3, 3, TST_NONE, OP_PUT ) - _OP_DEF(opexe_4, "get", 2, 2, TST_NONE, OP_GET ) - _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT ) - _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC ) - _OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) - _OP_DEF(opexe_4, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) - _OP_DEF(opexe_4, "oblist", 0, 0, 0, OP_OBLIST ) - _OP_DEF(opexe_4, "current-input-port", 0, 0, 0, OP_CURR_INPORT ) - _OP_DEF(opexe_4, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) - _OP_DEF(opexe_4, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) - _OP_DEF(opexe_4, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) - _OP_DEF(opexe_4, "open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) -#if USE_STRING_PORTS - _OP_DEF(opexe_4, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) - _OP_DEF(opexe_4, "open-output-string", 1, 1, TST_STRING, OP_OPEN_OUTSTRING ) - _OP_DEF(opexe_4, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) -#endif - _OP_DEF(opexe_4, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) - _OP_DEF(opexe_4, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) - _OP_DEF(opexe_4, "interaction-environment", 0, 0, 0, OP_INT_ENV ) - _OP_DEF(opexe_4, "current-environment", 0, 0, 0, OP_CURR_ENV ) - _OP_DEF(opexe_5, "read", 0, 1, TST_INPORT, OP_READ ) - _OP_DEF(opexe_5, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) - _OP_DEF(opexe_5, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) - _OP_DEF(opexe_5, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) - _OP_DEF(opexe_5, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) - _OP_DEF(opexe_5, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDSEXPR ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDLIST ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDDOT ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQUOTE ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTE ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTEVEC ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUNQUOTE ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUQTSP ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDVEC ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P0LIST ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P1LIST ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_PVECFROM ) - _OP_DEF(opexe_6, "length", 1, 1, TST_LIST, OP_LIST_LENGTH ) - _OP_DEF(opexe_6, "assq", 2, 2, TST_NONE, OP_ASSQ ) - _OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) - _OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP ) - _OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP ) -#undef _OP_DEF diff --git a/tools/capone/src/pcre/pcre-chartables.c b/tools/capone/src/pcre/pcre-chartables.c deleted file mode 100644 index 55e413c..0000000 --- a/tools/capone/src/pcre/pcre-chartables.c +++ /dev/null @@ -1,183 +0,0 @@ -/************************************************* -* Perl-Compatible Regular Expressions * -*************************************************/ - -/* This file is automatically written by the dftables auxiliary -program. If you edit it by hand, you might like to edit the Makefile to -prevent its ever being regenerated. - -This file is #included in the compilation of pcre.c to build the default -character tables which are used when no tables are passed to the compile -function. */ - -static unsigned char pcre_default_tables[] = { - -/* This table is a lower casing table. */ - - 0, 1, 2, 3, 4, 5, 6, 7, - 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 20, 21, 22, 23, - 24, 25, 26, 27, 28, 29, 30, 31, - 32, 33, 34, 35, 36, 37, 38, 39, - 40, 41, 42, 43, 44, 45, 46, 47, - 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, - 64, 97, 98, 99,100,101,102,103, - 104,105,106,107,108,109,110,111, - 112,113,114,115,116,117,118,119, - 120,121,122, 91, 92, 93, 94, 95, - 96, 97, 98, 99,100,101,102,103, - 104,105,106,107,108,109,110,111, - 112,113,114,115,116,117,118,119, - 120,121,122,123,124,125,126,127, - 128,129,130,131,132,133,134,135, - 136,137,138,139,140,141,142,143, - 144,145,146,147,148,149,150,151, - 152,153,154,155,156,157,158,159, - 160,161,162,163,164,165,166,167, - 168,169,170,171,172,173,174,175, - 176,177,178,179,180,181,182,183, - 184,185,186,187,188,189,190,191, - 192,193,194,195,196,197,198,199, - 200,201,202,203,204,205,206,207, - 208,209,210,211,212,213,214,215, - 216,217,218,219,220,221,222,223, - 224,225,226,227,228,229,230,231, - 232,233,234,235,236,237,238,239, - 240,241,242,243,244,245,246,247, - 248,249,250,251,252,253,254,255, - -/* This table is a case flipping table. */ - - 0, 1, 2, 3, 4, 5, 6, 7, - 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 20, 21, 22, 23, - 24, 25, 26, 27, 28, 29, 30, 31, - 32, 33, 34, 35, 36, 37, 38, 39, - 40, 41, 42, 43, 44, 45, 46, 47, - 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, - 64, 97, 98, 99,100,101,102,103, - 104,105,106,107,108,109,110,111, - 112,113,114,115,116,117,118,119, - 120,121,122, 91, 92, 93, 94, 95, - 96, 65, 66, 67, 68, 69, 70, 71, - 72, 73, 74, 75, 76, 77, 78, 79, - 80, 81, 82, 83, 84, 85, 86, 87, - 88, 89, 90,123,124,125,126,127, - 128,129,130,131,132,133,134,135, - 136,137,138,139,140,141,142,143, - 144,145,146,147,148,149,150,151, - 152,153,154,155,156,157,158,159, - 160,161,162,163,164,165,166,167, - 168,169,170,171,172,173,174,175, - 176,177,178,179,180,181,182,183, - 184,185,186,187,188,189,190,191, - 192,193,194,195,196,197,198,199, - 200,201,202,203,204,205,206,207, - 208,209,210,211,212,213,214,215, - 216,217,218,219,220,221,222,223, - 224,225,226,227,228,229,230,231, - 232,233,234,235,236,237,238,239, - 240,241,242,243,244,245,246,247, - 248,249,250,251,252,253,254,255, - -/* This table contains bit maps for various character classes. -Each map is 32 bytes long and the bits run from the least -significant end of each byte. The classes that have their own -maps are: space, xdigit, digit, upper, lower, word, graph -print, punct, and cntrl. Other classes are built from combinations. */ - - 0x00,0x3e,0x00,0x00,0x01,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0x03, - 0x7e,0x00,0x00,0x00,0x7e,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xfe,0xff,0xff,0x07,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0x07, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0x03, - 0xfe,0xff,0xff,0x87,0xfe,0xff,0xff,0x07, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0x00,0x00,0x00,0x00,0xfe,0xff,0x00,0xfc, - 0x01,0x00,0x00,0xf8,0x01,0x00,0x00,0x78, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - - 0xff,0xff,0xff,0xff,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - -/* This table identifies various classes of character by individual bits: - 0x01 white space character - 0x02 letter - 0x04 decimal digit - 0x08 hexadecimal digit - 0x10 alphanumeric or '_' - 0x80 regular expression metacharacter or binary zero -*/ - - 0x80,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 0- 7 */ - 0x00,0x01,0x01,0x00,0x01,0x01,0x00,0x00, /* 8- 15 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 16- 23 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 24- 31 */ - 0x01,0x00,0x00,0x00,0x80,0x00,0x00,0x00, /* - ' */ - 0x80,0x80,0x80,0x80,0x00,0x00,0x80,0x00, /* ( - / */ - 0x1c,0x1c,0x1c,0x1c,0x1c,0x1c,0x1c,0x1c, /* 0 - 7 */ - 0x1c,0x1c,0x00,0x00,0x00,0x00,0x00,0x80, /* 8 - ? */ - 0x00,0x1a,0x1a,0x1a,0x1a,0x1a,0x1a,0x12, /* @ - G */ - 0x12,0x12,0x12,0x12,0x12,0x12,0x12,0x12, /* H - O */ - 0x12,0x12,0x12,0x12,0x12,0x12,0x12,0x12, /* P - W */ - 0x12,0x12,0x12,0x80,0x00,0x00,0x80,0x10, /* X - _ */ - 0x00,0x1a,0x1a,0x1a,0x1a,0x1a,0x1a,0x12, /* ` - g */ - 0x12,0x12,0x12,0x12,0x12,0x12,0x12,0x12, /* h - o */ - 0x12,0x12,0x12,0x12,0x12,0x12,0x12,0x12, /* p - w */ - 0x12,0x12,0x12,0x80,0x80,0x00,0x00,0x00, /* x -127 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 128-135 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 136-143 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 144-151 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 152-159 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 160-167 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 168-175 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 176-183 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 184-191 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 192-199 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 200-207 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 208-215 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 216-223 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 224-231 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 232-239 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 240-247 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00};/* 248-255 */ - -/* End of chartables.c */ diff --git a/tools/capone/src/pcre/pcre-config.h b/tools/capone/src/pcre/pcre-config.h deleted file mode 100644 index 55559d8..0000000 --- a/tools/capone/src/pcre/pcre-config.h +++ /dev/null @@ -1,108 +0,0 @@ -/* config.h. Generated by configure. */ - -/* On Unix systems config.in is converted by configure into config.h. PCRE is -written in Standard C, but there are a few non-standard things it can cope -with, allowing it to run on SunOS4 and other "close to standard" systems. - -On a non-Unix system you should just copy this file into config.h, and set up -the macros the way you need them. You should normally change the definitions of -HAVE_STRERROR and HAVE_MEMMOVE to 1. Unfortunately, because of the way autoconf -works, these cannot be made the defaults. If your system has bcopy() and not -memmove(), change the definition of HAVE_BCOPY instead of HAVE_MEMMOVE. If your -system has neither bcopy() nor memmove(), leave them both as 0; an emulation -function will be used. */ - -/* If you are compiling for a system that uses EBCDIC instead of ASCII -character codes, define this macro as 1. On systems that can use "configure", -this can be done via --enable-ebcdic. */ - -#ifndef EBCDIC -#define EBCDIC 0 -#endif - -/* If you are compiling for a system that needs some magic to be inserted -before the definition of an exported function, define this macro to contain the -relevant magic. It apears at the start of every exported function. */ - -#define EXPORT - -/* Define to empty if the "const" keyword does not work. */ - -/* #undef const */ - -/* Define to "unsigned" if doesn't define size_t. */ - -/* #undef size_t */ - -/* The following two definitions are mainly for the benefit of SunOS4, which -doesn't have the strerror() or memmove() functions that should be present in -all Standard C libraries. The macros HAVE_STRERROR and HAVE_MEMMOVE should -normally be defined with the value 1 for other systems, but unfortunately we -can't make this the default because "configure" files generated by autoconf -will only change 0 to 1; they won't change 1 to 0 if the functions are not -found. */ - -#define HAVE_STRERROR 1 -#define HAVE_MEMMOVE 1 - -/* There are some non-Unix systems that don't even have bcopy(). If this macro -is false, an emulation is used. If HAVE_MEMMOVE is set to 1, the value of -HAVE_BCOPY is not relevant. */ - -#define HAVE_BCOPY 1 - -/* The value of NEWLINE determines the newline character. The default is to -leave it up to the compiler, but some sites want to force a particular value. -On Unix systems, "configure" can be used to override this default. */ - -#ifndef NEWLINE -#define NEWLINE '\n' -#endif - -/* The value of LINK_SIZE determines the number of bytes used to store -links as offsets within the compiled regex. The default is 2, which allows for -compiled patterns up to 64K long. This covers the vast majority of cases. -However, PCRE can also be compiled to use 3 or 4 bytes instead. This allows for -longer patterns in extreme cases. On Unix systems, "configure" can be used to -override this default. */ - -#ifndef LINK_SIZE -#define LINK_SIZE 2 -#endif - -/* The value of MATCH_LIMIT determines the default number of times the match() -function can be called during a single execution of pcre_exec(). (There is a -runtime method of setting a different limit.) The limit exists in order to -catch runaway regular expressions that take for ever to determine that they do -not match. The default is set very large so that it does not accidentally catch -legitimate cases. On Unix systems, "configure" can be used to override this -default default. */ - -#ifndef MATCH_LIMIT -#define MATCH_LIMIT 10000000 -#endif - -/* When calling PCRE via the POSIX interface, additional working storage is -required for holding the pointers to capturing substrings because PCRE requires -three integers per substring, whereas the POSIX interface provides only two. If -the number of expected substrings is small, the wrapper function uses space on -the stack, because this is faster than using malloc() for each call. The -threshold above which the stack is no longer use is defined by POSIX_MALLOC_ -THRESHOLD. On Unix systems, "configure" can be used to override this default. -*/ - -#ifndef POSIX_MALLOC_THRESHOLD -#define POSIX_MALLOC_THRESHOLD 10 -#endif - -/* PCRE uses recursive function calls to handle backtracking while matching. -This can sometimes be a problem on systems that have stacks of limited size. -Define NO_RECURSE to get a version that doesn't use recursion in the match() -function; instead it creates its own stack by steam using pcre_recurse_malloc -to get memory. For more detail, see comments and other stuff just above the -match() function. On Unix systems, "configure" can be used to set this in the -Makefile (use --disable-stack-for-recursion). */ - -/* #define NO_RECURSE */ - -/* End */ diff --git a/tools/capone/src/pcre/pcre-internal.h b/tools/capone/src/pcre/pcre-internal.h deleted file mode 100644 index 44ea4cf..0000000 --- a/tools/capone/src/pcre/pcre-internal.h +++ /dev/null @@ -1,752 +0,0 @@ -/************************************************* -* Perl-Compatible Regular Expressions * -*************************************************/ - - -/* This is a library of functions to support regular expressions whose syntax -and semantics are as close as possible to those of the Perl 5 language. See -the file doc/Tech.Notes for some information on the internals. - -Written by: Philip Hazel - - Copyright (c) 1997-2004 University of Cambridge - ------------------------------------------------------------------------------ -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - * Neither the name of the University of Cambridge nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. ------------------------------------------------------------------------------ -*/ - -/* This header contains definitions that are shared between the different -modules, but which are not relevant to the outside. */ - -/* Get the definitions provided by running "configure" */ - -#include "pcre-config.h" - -/* Standard C headers plus the external interface definition. The only time -setjmp and stdarg are used is when NO_RECURSE is set. */ - -#include -#include -#include -#include -#include -#include -#include -#include - -#ifndef PCRE_SPY -#define PCRE_DEFINITION /* Win32 __declspec(export) trigger for .dll */ -#endif - -/* We need to have types that specify unsigned 16-bit and 32-bit integers. We -cannot determine these outside the compilation (e.g. by running a program as -part of "configure") because PCRE is often cross-compiled for use on other -systems. Instead we make use of the maximum sizes that are available at -preprocessor time in standard C environments. */ - -#if USHRT_MAX == 65535 - typedef unsigned short pcre_uint16; -#elif UINT_MAX == 65535 - typedef unsigned int pcre_uint16; -#else - #error Cannot determine a type for 16-bit unsigned integers -#endif - -#if UINT_MAX == 4294967295 - typedef unsigned int pcre_uint32; -#elif ULONG_MAX == 4294967295 - typedef unsigned long int pcre_uint32; -#else - #error Cannot determine a type for 32-bit unsigned integers -#endif - -/* All character handling must be done as unsigned characters. Otherwise there -are problems with top-bit-set characters and functions such as isspace(). -However, we leave the interface to the outside world as char *, because that -should make things easier for callers. We define a short type for unsigned char -to save lots of typing. I tried "uchar", but it causes problems on Digital -Unix, where it is defined in sys/types, so use "uschar" instead. */ - -typedef unsigned char uschar; - -/* Include the public PCRE header */ - -#include "pcre.h" - -/* When compiling for use with the Virtual Pascal compiler, these functions -need to have their names changed. PCRE must be compiled with the -DVPCOMPAT -option on the command line. */ - -#ifdef VPCOMPAT -#define strncmp(s1,s2,m) _strncmp(s1,s2,m) -#define memcpy(d,s,n) _memcpy(d,s,n) -#define memmove(d,s,n) _memmove(d,s,n) -#define memset(s,c,n) _memset(s,c,n) -#else /* VPCOMPAT */ - -/* To cope with SunOS4 and other systems that lack memmove() but have bcopy(), -define a macro for memmove() if HAVE_MEMMOVE is false, provided that HAVE_BCOPY -is set. Otherwise, include an emulating function for those systems that have -neither (there some non-Unix environments where this is the case). This assumes -that all calls to memmove are moving strings upwards in store, which is the -case in PCRE. */ - -#if ! HAVE_MEMMOVE -#undef memmove /* some systems may have a macro */ -#if HAVE_BCOPY -#define memmove(a, b, c) bcopy(b, a, c) -#else /* HAVE_BCOPY */ -void * -pcre_memmove(unsigned char *dest, const unsigned char *src, size_t n) -{ -int i; -dest += n; -src += n; -for (i = 0; i < n; ++i) *(--dest) = *(--src); -} -#define memmove(a, b, c) pcre_memmove(a, b, c) -#endif /* not HAVE_BCOPY */ -#endif /* not HAVE_MEMMOVE */ -#endif /* not VPCOMPAT */ - - -/* PCRE keeps offsets in its compiled code as 2-byte quantities (always stored -in big-endian order) by default. These are used, for example, to link from the -start of a subpattern to its alternatives and its end. The use of 2 bytes per -offset limits the size of the compiled regex to around 64K, which is big enough -for almost everybody. However, I received a request for an even bigger limit. -For this reason, and also to make the code easier to maintain, the storing and -loading of offsets from the byte string is now handled by the macros that are -defined here. - -The macros are controlled by the value of LINK_SIZE. This defaults to 2 in -the config.h file, but can be overridden by using -D on the command line. This -is automated on Unix systems via the "configure" command. */ - -#if LINK_SIZE == 2 - -#define PUT(a,n,d) \ - (a[n] = (d) >> 8), \ - (a[(n)+1] = (d) & 255) - -#define GET(a,n) \ - (((a)[n] << 8) | (a)[(n)+1]) - -#define MAX_PATTERN_SIZE (1 << 16) - - -#elif LINK_SIZE == 3 - -#define PUT(a,n,d) \ - (a[n] = (d) >> 16), \ - (a[(n)+1] = (d) >> 8), \ - (a[(n)+2] = (d) & 255) - -#define GET(a,n) \ - (((a)[n] << 16) | ((a)[(n)+1] << 8) | (a)[(n)+2]) - -#define MAX_PATTERN_SIZE (1 << 24) - - -#elif LINK_SIZE == 4 - -#define PUT(a,n,d) \ - (a[n] = (d) >> 24), \ - (a[(n)+1] = (d) >> 16), \ - (a[(n)+2] = (d) >> 8), \ - (a[(n)+3] = (d) & 255) - -#define GET(a,n) \ - (((a)[n] << 24) | ((a)[(n)+1] << 16) | ((a)[(n)+2] << 8) | (a)[(n)+3]) - -#define MAX_PATTERN_SIZE (1 << 30) /* Keep it positive */ - - -#else -#error LINK_SIZE must be either 2, 3, or 4 -#endif - - -/* Convenience macro defined in terms of the others */ - -#define PUTINC(a,n,d) PUT(a,n,d), a += LINK_SIZE - - -/* PCRE uses some other 2-byte quantities that do not change when the size of -offsets changes. There are used for repeat counts and for other things such as -capturing parenthesis numbers in back references. */ - -#define PUT2(a,n,d) \ - a[n] = (d) >> 8; \ - a[(n)+1] = (d) & 255 - -#define GET2(a,n) \ - (((a)[n] << 8) | (a)[(n)+1]) - -#define PUT2INC(a,n,d) PUT2(a,n,d), a += 2 - - -/* In case there is no definition of offsetof() provided - though any proper -Standard C system should have one. */ - -#ifndef offsetof -#define offsetof(p_type,field) ((size_t)&(((p_type *)0)->field)) -#endif - - -/* These are the public options that can change during matching. */ - -#define PCRE_IMS (PCRE_CASELESS|PCRE_MULTILINE|PCRE_DOTALL) - -/* Private options flags start at the most significant end of the four bytes, -but skip the top bit so we can use ints for convenience without getting tangled -with negative values. The public options defined in pcre.h start at the least -significant end. Make sure they don't overlap, though now that we have expanded -to four bytes, there is plenty of space. */ - -#define PCRE_FIRSTSET 0x40000000 /* first_byte is set */ -#define PCRE_REQCHSET 0x20000000 /* req_byte is set */ -#define PCRE_STARTLINE 0x10000000 /* start after \n for multiline */ -#define PCRE_ICHANGED 0x08000000 /* i option changes within regex */ -#define PCRE_NOPARTIAL 0x04000000 /* can't use partial with this regex */ - -/* Options for the "extra" block produced by pcre_study(). */ - -#define PCRE_STUDY_MAPPED 0x01 /* a map of starting chars exists */ - -/* Masks for identifying the public options which are permitted at compile -time, run time or study time, respectively. */ - -#define PUBLIC_OPTIONS \ - (PCRE_CASELESS|PCRE_EXTENDED|PCRE_ANCHORED|PCRE_MULTILINE| \ - PCRE_DOTALL|PCRE_DOLLAR_ENDONLY|PCRE_EXTRA|PCRE_UNGREEDY|PCRE_UTF8| \ - PCRE_NO_AUTO_CAPTURE|PCRE_NO_UTF8_CHECK|PCRE_AUTO_CALLOUT) - -#define PUBLIC_EXEC_OPTIONS \ - (PCRE_ANCHORED|PCRE_NOTBOL|PCRE_NOTEOL|PCRE_NOTEMPTY|PCRE_NO_UTF8_CHECK| \ - PCRE_PARTIAL) - -#define PUBLIC_STUDY_OPTIONS 0 /* None defined */ - -/* Magic number to provide a small check against being handed junk. */ - -#define MAGIC_NUMBER 0x50435245UL /* 'PCRE' */ - -/* Negative values for the firstchar and reqchar variables */ - -#define REQ_UNSET (-2) -#define REQ_NONE (-1) - -/* Flags added to firstbyte or reqbyte; a "non-literal" item is either a -variable-length repeat, or a anything other than literal characters. */ - -#define REQ_CASELESS 0x0100 /* indicates caselessness */ -#define REQ_VARY 0x0200 /* reqbyte followed non-literal item */ - -/* Miscellaneous definitions */ - -typedef int BOOL; - -#define FALSE 0 -#define TRUE 1 - -/* Escape items that are just an encoding of a particular data value. Note that -ESC_n is defined as yet another macro, which is set in config.h to either \n -(the default) or \r (which some people want). */ - -#ifndef ESC_e -#define ESC_e 27 -#endif - -#ifndef ESC_f -#define ESC_f '\f' -#endif - -#ifndef ESC_n -#define ESC_n NEWLINE -#endif - -#ifndef ESC_r -#define ESC_r '\r' -#endif - -/* We can't officially use ESC_t because it is a POSIX reserved identifier -(presumably because of all the others like size_t). */ - -#ifndef ESC_tee -#define ESC_tee '\t' -#endif - -/* These are escaped items that aren't just an encoding of a particular data -value such as \n. They must have non-zero values, as check_escape() returns -their negation. Also, they must appear in the same order as in the opcode -definitions below, up to ESC_z. There's a dummy for OP_ANY because it -corresponds to "." rather than an escape sequence. The final one must be -ESC_REF as subsequent values are used for \1, \2, \3, etc. There is are two -tests in the code for an escape greater than ESC_b and less than ESC_Z to -detect the types that may be repeated. These are the types that consume -characters. If any new escapes are put in between that don't consume a -character, that code will have to change. */ - -enum { ESC_A = 1, ESC_G, ESC_B, ESC_b, ESC_D, ESC_d, ESC_S, ESC_s, ESC_W, - ESC_w, ESC_dum1, ESC_C, ESC_P, ESC_p, ESC_X, ESC_Z, ESC_z, ESC_E, - ESC_Q, ESC_REF }; - -/* Flag bits and data types for the extended class (OP_XCLASS) for classes that -contain UTF-8 characters with values greater than 255. */ - -#define XCL_NOT 0x01 /* Flag: this is a negative class */ -#define XCL_MAP 0x02 /* Flag: a 32-byte map is present */ - -#define XCL_END 0 /* Marks end of individual items */ -#define XCL_SINGLE 1 /* Single item (one multibyte char) follows */ -#define XCL_RANGE 2 /* A range (two multibyte chars) follows */ -#define XCL_PROP 3 /* Unicode property (one property code) follows */ -#define XCL_NOTPROP 4 /* Unicode inverted property (ditto) */ - - -/* Opcode table: OP_BRA must be last, as all values >= it are used for brackets -that extract substrings. Starting from 1 (i.e. after OP_END), the values up to -OP_EOD must correspond in order to the list of escapes immediately above. -Note that whenever this list is updated, the two macro definitions that follow -must also be updated to match. */ - -enum { - OP_END, /* 0 End of pattern */ - - /* Values corresponding to backslashed metacharacters */ - - OP_SOD, /* 1 Start of data: \A */ - OP_SOM, /* 2 Start of match (subject + offset): \G */ - OP_NOT_WORD_BOUNDARY, /* 3 \B */ - OP_WORD_BOUNDARY, /* 4 \b */ - OP_NOT_DIGIT, /* 5 \D */ - OP_DIGIT, /* 6 \d */ - OP_NOT_WHITESPACE, /* 7 \S */ - OP_WHITESPACE, /* 8 \s */ - OP_NOT_WORDCHAR, /* 9 \W */ - OP_WORDCHAR, /* 10 \w */ - OP_ANY, /* 11 Match any character */ - OP_ANYBYTE, /* 12 Match any byte (\C); different to OP_ANY for UTF-8 */ - OP_NOTPROP, /* 13 \P (not Unicode property) */ - OP_PROP, /* 14 \p (Unicode property) */ - OP_EXTUNI, /* 15 \X (extended Unicode sequence */ - OP_EODN, /* 16 End of data or \n at end of data: \Z. */ - OP_EOD, /* 17 End of data: \z */ - - OP_OPT, /* 18 Set runtime options */ - OP_CIRC, /* 19 Start of line - varies with multiline switch */ - OP_DOLL, /* 20 End of line - varies with multiline switch */ - OP_CHAR, /* 21 Match one character, casefully */ - OP_CHARNC, /* 22 Match one character, caselessly */ - OP_NOT, /* 23 Match anything but the following char */ - - OP_STAR, /* 24 The maximizing and minimizing versions of */ - OP_MINSTAR, /* 25 all these opcodes must come in pairs, with */ - OP_PLUS, /* 26 the minimizing one second. */ - OP_MINPLUS, /* 27 This first set applies to single characters */ - OP_QUERY, /* 28 */ - OP_MINQUERY, /* 29 */ - OP_UPTO, /* 30 From 0 to n matches */ - OP_MINUPTO, /* 31 */ - OP_EXACT, /* 32 Exactly n matches */ - - OP_NOTSTAR, /* 33 The maximizing and minimizing versions of */ - OP_NOTMINSTAR, /* 34 all these opcodes must come in pairs, with */ - OP_NOTPLUS, /* 35 the minimizing one second. */ - OP_NOTMINPLUS, /* 36 This set applies to "not" single characters */ - OP_NOTQUERY, /* 37 */ - OP_NOTMINQUERY, /* 38 */ - OP_NOTUPTO, /* 39 From 0 to n matches */ - OP_NOTMINUPTO, /* 40 */ - OP_NOTEXACT, /* 41 Exactly n matches */ - - OP_TYPESTAR, /* 42 The maximizing and minimizing versions of */ - OP_TYPEMINSTAR, /* 43 all these opcodes must come in pairs, with */ - OP_TYPEPLUS, /* 44 the minimizing one second. These codes must */ - OP_TYPEMINPLUS, /* 45 be in exactly the same order as those above. */ - OP_TYPEQUERY, /* 46 This set applies to character types such as \d */ - OP_TYPEMINQUERY, /* 47 */ - OP_TYPEUPTO, /* 48 From 0 to n matches */ - OP_TYPEMINUPTO, /* 49 */ - OP_TYPEEXACT, /* 50 Exactly n matches */ - - OP_CRSTAR, /* 51 The maximizing and minimizing versions of */ - OP_CRMINSTAR, /* 52 all these opcodes must come in pairs, with */ - OP_CRPLUS, /* 53 the minimizing one second. These codes must */ - OP_CRMINPLUS, /* 54 be in exactly the same order as those above. */ - OP_CRQUERY, /* 55 These are for character classes and back refs */ - OP_CRMINQUERY, /* 56 */ - OP_CRRANGE, /* 57 These are different to the three sets above. */ - OP_CRMINRANGE, /* 58 */ - - OP_CLASS, /* 59 Match a character class, chars < 256 only */ - OP_NCLASS, /* 60 Same, but the bitmap was created from a negative - class - the difference is relevant only when a UTF-8 - character > 255 is encountered. */ - - OP_XCLASS, /* 61 Extended class for handling UTF-8 chars within the - class. This does both positive and negative. */ - - OP_REF, /* 62 Match a back reference */ - OP_RECURSE, /* 63 Match a numbered subpattern (possibly recursive) */ - OP_CALLOUT, /* 64 Call out to external function if provided */ - - OP_ALT, /* 65 Start of alternation */ - OP_KET, /* 66 End of group that doesn't have an unbounded repeat */ - OP_KETRMAX, /* 67 These two must remain together and in this */ - OP_KETRMIN, /* 68 order. They are for groups the repeat for ever. */ - - /* The assertions must come before ONCE and COND */ - - OP_ASSERT, /* 69 Positive lookahead */ - OP_ASSERT_NOT, /* 70 Negative lookahead */ - OP_ASSERTBACK, /* 71 Positive lookbehind */ - OP_ASSERTBACK_NOT, /* 72 Negative lookbehind */ - OP_REVERSE, /* 73 Move pointer back - used in lookbehind assertions */ - - /* ONCE and COND must come after the assertions, with ONCE first, as there's - a test for >= ONCE for a subpattern that isn't an assertion. */ - - OP_ONCE, /* 74 Once matched, don't back up into the subpattern */ - OP_COND, /* 75 Conditional group */ - OP_CREF, /* 76 Used to hold an extraction string number (cond ref) */ - - OP_BRAZERO, /* 77 These two must remain together and in this */ - OP_BRAMINZERO, /* 78 order. */ - - OP_BRANUMBER, /* 79 Used for extracting brackets whose number is greater - than can fit into an opcode. */ - - OP_BRA /* 80 This and greater values are used for brackets that - extract substrings up to EXTRACT_BASIC_MAX. After - that, use is made of OP_BRANUMBER. */ -}; - -/* WARNING WARNING WARNING: There is an implicit assumption in pcre.c and -study.c that all opcodes are less than 128 in value. This makes handling UTF-8 -character sequences easier. */ - -/* The highest extraction number before we have to start using additional -bytes. (Originally PCRE didn't have support for extraction counts highter than -this number.) The value is limited by the number of opcodes left after OP_BRA, -i.e. 255 - OP_BRA. We actually set it a bit lower to leave room for additional -opcodes. */ - -#define EXTRACT_BASIC_MAX 100 - - -/* This macro defines textual names for all the opcodes. There are used only -for debugging, in pcre.c when DEBUG is defined, and also in pcretest.c. The -macro is referenced only in printint.c. */ - -#define OP_NAME_LIST \ - "End", "\\A", "\\G", "\\B", "\\b", "\\D", "\\d", \ - "\\S", "\\s", "\\W", "\\w", "Any", "Anybyte", \ - "notprop", "prop", "extuni", \ - "\\Z", "\\z", \ - "Opt", "^", "$", "char", "charnc", "not", \ - "*", "*?", "+", "+?", "?", "??", "{", "{", "{", \ - "*", "*?", "+", "+?", "?", "??", "{", "{", "{", \ - "*", "*?", "+", "+?", "?", "??", "{", "{", "{", \ - "*", "*?", "+", "+?", "?", "??", "{", "{", \ - "class", "nclass", "xclass", "Ref", "Recurse", "Callout", \ - "Alt", "Ket", "KetRmax", "KetRmin", "Assert", "Assert not", \ - "AssertB", "AssertB not", "Reverse", "Once", "Cond", "Cond ref",\ - "Brazero", "Braminzero", "Branumber", "Bra" - - -/* This macro defines the length of fixed length operations in the compiled -regex. The lengths are used when searching for specific things, and also in the -debugging printing of a compiled regex. We use a macro so that it can be -incorporated both into pcre.c and pcretest.c without being publicly exposed. - -As things have been extended, some of these are no longer fixed lenths, but are -minima instead. For example, the length of a single-character repeat may vary -in UTF-8 mode. The code that uses this table must know about such things. */ - -#define OP_LENGTHS \ - 1, /* End */ \ - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* \A, \G, \B, \B, \D, \d, \S, \s, \W, \w */ \ - 1, 1, /* Any, Anybyte */ \ - 2, 2, 1, /* NOTPROP, PROP, EXTUNI */ \ - 1, 1, 2, 1, 1, /* \Z, \z, Opt, ^, $ */ \ - 2, /* Char - the minimum length */ \ - 2, /* Charnc - the minimum length */ \ - 2, /* not */ \ - /* Positive single-char repeats ** These are */ \ - 2, 2, 2, 2, 2, 2, /* *, *?, +, +?, ?, ?? ** minima in */ \ - 4, 4, 4, /* upto, minupto, exact ** UTF-8 mode */ \ - /* Negative single-char repeats - only for chars < 256 */ \ - 2, 2, 2, 2, 2, 2, /* NOT *, *?, +, +?, ?, ?? */ \ - 4, 4, 4, /* NOT upto, minupto, exact */ \ - /* Positive type repeats */ \ - 2, 2, 2, 2, 2, 2, /* Type *, *?, +, +?, ?, ?? */ \ - 4, 4, 4, /* Type upto, minupto, exact */ \ - /* Character class & ref repeats */ \ - 1, 1, 1, 1, 1, 1, /* *, *?, +, +?, ?, ?? */ \ - 5, 5, /* CRRANGE, CRMINRANGE */ \ - 33, /* CLASS */ \ - 33, /* NCLASS */ \ - 0, /* XCLASS - variable length */ \ - 3, /* REF */ \ - 1+LINK_SIZE, /* RECURSE */ \ - 2+2*LINK_SIZE, /* CALLOUT */ \ - 1+LINK_SIZE, /* Alt */ \ - 1+LINK_SIZE, /* Ket */ \ - 1+LINK_SIZE, /* KetRmax */ \ - 1+LINK_SIZE, /* KetRmin */ \ - 1+LINK_SIZE, /* Assert */ \ - 1+LINK_SIZE, /* Assert not */ \ - 1+LINK_SIZE, /* Assert behind */ \ - 1+LINK_SIZE, /* Assert behind not */ \ - 1+LINK_SIZE, /* Reverse */ \ - 1+LINK_SIZE, /* Once */ \ - 1+LINK_SIZE, /* COND */ \ - 3, /* CREF */ \ - 1, 1, /* BRAZERO, BRAMINZERO */ \ - 3, /* BRANUMBER */ \ - 1+LINK_SIZE /* BRA */ \ - - -/* A magic value for OP_CREF to indicate the "in recursion" condition. */ - -#define CREF_RECURSE 0xffff - -/* The texts of compile-time error messages are defined as macros here so that -they can be accessed by the POSIX wrapper and converted into error codes. Yes, -I could have used error codes in the first place, but didn't feel like changing -just to accommodate the POSIX wrapper. */ - -#define ERR1 "\\ at end of pattern" -#define ERR2 "\\c at end of pattern" -#define ERR3 "unrecognized character follows \\" -#define ERR4 "numbers out of order in {} quantifier" -#define ERR5 "number too big in {} quantifier" -#define ERR6 "missing terminating ] for character class" -#define ERR7 "invalid escape sequence in character class" -#define ERR8 "range out of order in character class" -#define ERR9 "nothing to repeat" -#define ERR10 "operand of unlimited repeat could match the empty string" -#define ERR11 "internal error: unexpected repeat" -#define ERR12 "unrecognized character after (?" -#define ERR13 "POSIX named classes are supported only within a class" -#define ERR14 "missing )" -#define ERR15 "reference to non-existent subpattern" -#define ERR16 "erroffset passed as NULL" -#define ERR17 "unknown option bit(s) set" -#define ERR18 "missing ) after comment" -#define ERR19 "parentheses nested too deeply" -#define ERR20 "regular expression too large" -#define ERR21 "failed to get memory" -#define ERR22 "unmatched parentheses" -#define ERR23 "internal error: code overflow" -#define ERR24 "unrecognized character after (?<" -#define ERR25 "lookbehind assertion is not fixed length" -#define ERR26 "malformed number after (?(" -#define ERR27 "conditional group contains more than two branches" -#define ERR28 "assertion expected after (?(" -#define ERR29 "(?R or (?digits must be followed by )" -#define ERR30 "unknown POSIX class name" -#define ERR31 "POSIX collating elements are not supported" -#define ERR32 "this version of PCRE is not compiled with PCRE_UTF8 support" -#define ERR33 "spare error" -#define ERR34 "character value in \\x{...} sequence is too large" -#define ERR35 "invalid condition (?(0)" -#define ERR36 "\\C not allowed in lookbehind assertion" -#define ERR37 "PCRE does not support \\L, \\l, \\N, \\U, or \\u" -#define ERR38 "number after (?C is > 255" -#define ERR39 "closing ) for (?C expected" -#define ERR40 "recursive call could loop indefinitely" -#define ERR41 "unrecognized character after (?P" -#define ERR42 "syntax error after (?P" -#define ERR43 "two named groups have the same name" -#define ERR44 "invalid UTF-8 string" -#define ERR45 "support for \\P, \\p, and \\X has not been compiled" -#define ERR46 "malformed \\P or \\p sequence" -#define ERR47 "unknown property name after \\P or \\p" - -/* The real format of the start of the pcre block; the index of names and the -code vector run on as long as necessary after the end. We store an explicit -offset to the name table so that if a regex is compiled on one host, saved, and -then run on another where the size of pointers is different, all might still -be well. For the case of compiled-on-4 and run-on-8, we include an extra -pointer that is always NULL. For future-proofing, we also include a few dummy -fields - even though you can never get this planning right! - -NOTE NOTE NOTE: -Because people can now save and re-use compiled patterns, any additions to this -structure should be made at the end, and something earlier (e.g. a new -flag in the options or one of the dummy fields) should indicate that the new -fields are present. Currently PCRE always sets the dummy fields to zero. -NOTE NOTE NOTE: -*/ - -typedef struct real_pcre { - pcre_uint32 magic_number; - pcre_uint32 size; /* Total that was malloced */ - pcre_uint32 options; - pcre_uint32 dummy1; /* For future use, maybe */ - - pcre_uint16 top_bracket; - pcre_uint16 top_backref; - pcre_uint16 first_byte; - pcre_uint16 req_byte; - pcre_uint16 name_table_offset; /* Offset to name table that follows */ - pcre_uint16 name_entry_size; /* Size of any name items */ - pcre_uint16 name_count; /* Number of name items */ - pcre_uint16 dummy2; /* For future use, maybe */ - - const unsigned char *tables; /* Pointer to tables or NULL for std */ - const unsigned char *nullpad; /* NULL padding */ -} real_pcre; - -/* The format of the block used to store data from pcre_study(). The same -remark (see NOTE above) about extending this structure applies. */ - -typedef struct pcre_study_data { - pcre_uint32 size; /* Total that was malloced */ - pcre_uint32 options; - uschar start_bits[32]; -} pcre_study_data; - -/* Structure for passing "static" information around between the functions -doing the compiling, so that they are thread-safe. */ - -typedef struct compile_data { - const uschar *lcc; /* Points to lower casing table */ - const uschar *fcc; /* Points to case-flipping table */ - const uschar *cbits; /* Points to character type table */ - const uschar *ctypes; /* Points to table of type maps */ - const uschar *start_code; /* The start of the compiled code */ - const uschar *start_pattern; /* The start of the pattern */ - uschar *name_table; /* The name/number table */ - int names_found; /* Number of entries so far */ - int name_entry_size; /* Size of each entry */ - int top_backref; /* Maximum back reference */ - unsigned int backref_map; /* Bitmap of low back refs */ - int req_varyopt; /* "After variable item" flag for reqbyte */ - BOOL nopartial; /* Set TRUE if partial won't work */ -} compile_data; - -/* Structure for maintaining a chain of pointers to the currently incomplete -branches, for testing for left recursion. */ - -typedef struct branch_chain { - struct branch_chain *outer; - uschar *current; -} branch_chain; - -/* Structure for items in a linked list that represents an explicit recursive -call within the pattern. */ - -typedef struct recursion_info { - struct recursion_info *prevrec; /* Previous recursion record (or NULL) */ - int group_num; /* Number of group that was called */ - const uschar *after_call; /* "Return value": points after the call in the expr */ - const uschar *save_start; /* Old value of md->start_match */ - int *offset_save; /* Pointer to start of saved offsets */ - int saved_max; /* Number of saved offsets */ -} recursion_info; - -/* When compiling in a mode that doesn't use recursive calls to match(), -a structure is used to remember local variables on the heap. It is defined in -pcre.c, close to the match() function, so that it is easy to keep it in step -with any changes of local variable. However, the pointer to the current frame -must be saved in some "static" place over a longjmp(). We declare the -structure here so that we can put a pointer in the match_data structure. -NOTE: This isn't used for a "normal" compilation of pcre. */ - -struct heapframe; - -/* Structure for passing "static" information around between the functions -doing the matching, so that they are thread-safe. */ - -typedef struct match_data { - unsigned long int match_call_count; /* As it says */ - unsigned long int match_limit;/* As it says */ - int *offset_vector; /* Offset vector */ - int offset_end; /* One past the end */ - int offset_max; /* The maximum usable for return data */ - const uschar *lcc; /* Points to lower casing table */ - const uschar *ctypes; /* Points to table of type maps */ - BOOL offset_overflow; /* Set if too many extractions */ - BOOL notbol; /* NOTBOL flag */ - BOOL noteol; /* NOTEOL flag */ - BOOL utf8; /* UTF8 flag */ - BOOL endonly; /* Dollar not before final \n */ - BOOL notempty; /* Empty string match not wanted */ - BOOL partial; /* PARTIAL flag */ - BOOL hitend; /* Hit the end of the subject at some point */ - const uschar *start_code; /* For use when recursing */ - const uschar *start_subject; /* Start of the subject string */ - const uschar *end_subject; /* End of the subject string */ - const uschar *start_match; /* Start of this match attempt */ - const uschar *end_match_ptr; /* Subject position at end match */ - int end_offset_top; /* Highwater mark at end of match */ - int capture_last; /* Most recent capture number */ - int start_offset; /* The start offset value */ - recursion_info *recursive; /* Linked list of recursion data */ - void *callout_data; /* To pass back to callouts */ - struct heapframe *thisframe; /* Used only when compiling for no recursion */ -} match_data; - -/* Bit definitions for entries in the pcre_ctypes table. */ - -#define ctype_space 0x01 -#define ctype_letter 0x02 -#define ctype_digit 0x04 -#define ctype_xdigit 0x08 -#define ctype_word 0x10 /* alphameric or '_' */ -#define ctype_meta 0x80 /* regexp meta char or zero (end pattern) */ - -/* Offsets for the bitmap tables in pcre_cbits. Each table contains a set -of bits for a class map. Some classes are built by combining these tables. */ - -#define cbit_space 0 /* [:space:] or \s */ -#define cbit_xdigit 32 /* [:xdigit:] */ -#define cbit_digit 64 /* [:digit:] or \d */ -#define cbit_upper 96 /* [:upper:] */ -#define cbit_lower 128 /* [:lower:] */ -#define cbit_word 160 /* [:word:] or \w */ -#define cbit_graph 192 /* [:graph:] */ -#define cbit_print 224 /* [:print:] */ -#define cbit_punct 256 /* [:punct:] */ -#define cbit_cntrl 288 /* [:cntrl:] */ -#define cbit_length 320 /* Length of the cbits table */ - -/* Offsets of the various tables from the base tables pointer, and -total length. */ - -#define lcc_offset 0 -#define fcc_offset 256 -#define cbits_offset 512 -#define ctypes_offset (cbits_offset + cbit_length) -#define tables_length (ctypes_offset + 256) - -/* End of internal.h */ diff --git a/tools/capone/src/pcre/pcre.c b/tools/capone/src/pcre/pcre.c deleted file mode 100644 index 09b7972..0000000 --- a/tools/capone/src/pcre/pcre.c +++ /dev/null @@ -1,9197 +0,0 @@ -/************************************************* -* Perl-Compatible Regular Expressions * -*************************************************/ - -/* -This is a library of functions to support regular expressions whose syntax -and semantics are as close as possible to those of the Perl 5 language. See -the file Tech.Notes for some information on the internals. - -Written by: Philip Hazel - - Copyright (c) 1997-2004 University of Cambridge - ------------------------------------------------------------------------------ -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - * Neither the name of the University of Cambridge nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. ------------------------------------------------------------------------------ -*/ - - -/* Define DEBUG to get debugging output on stdout. */ -/* #define DEBUG */ - -/* Use a macro for debugging printing, 'cause that eliminates the use of #ifdef -inline, and there are *still* stupid compilers about that don't like indented -pre-processor statements. I suppose it's only been 10 years... */ - -#ifdef DEBUG -#define DPRINTF(p) printf p -#else -#define DPRINTF(p) /*nothing*/ -#endif - -/* Include the internals header, which itself includes "config.h", the Standard -C headers, and the external pcre header. */ - -#include "pcre-internal.h" - -/* If Unicode Property support is wanted, include a private copy of the -function that does it, and the table that translates names to numbers. */ - -#ifdef SUPPORT_UCP -#include "ucp.c" -#include "ucptypetable.c" -#endif - -/* Maximum number of items on the nested bracket stacks at compile time. This -applies to the nesting of all kinds of parentheses. It does not limit -un-nested, non-capturing parentheses. This number can be made bigger if -necessary - it is used to dimension one int and one unsigned char vector at -compile time. */ - -#define BRASTACK_SIZE 200 - - -/* Maximum number of ints of offset to save on the stack for recursive calls. -If the offset vector is bigger, malloc is used. This should be a multiple of 3, -because the offset vector is always a multiple of 3 long. */ - -#define REC_STACK_SAVE_MAX 30 - - -/* The maximum remaining length of subject we are prepared to search for a -req_byte match. */ - -#define REQ_BYTE_MAX 1000 - - -/* Table of sizes for the fixed-length opcodes. It's defined in a macro so that -the definition is next to the definition of the opcodes in internal.h. */ - -static const uschar OP_lengths[] = { OP_LENGTHS }; - -/* Min and max values for the common repeats; for the maxima, 0 => infinity */ - -static const char rep_min[] = { 0, 0, 1, 1, 0, 0 }; -static const char rep_max[] = { 0, 0, 0, 0, 1, 1 }; - -/* Table for handling escaped characters in the range '0'-'z'. Positive returns -are simple data values; negative values are for special things like \d and so -on. Zero means further processing is needed (for things like \x), or the escape -is invalid. */ - -#if !EBCDIC /* This is the "normal" table for ASCII systems */ -static const short int escapes[] = { - 0, 0, 0, 0, 0, 0, 0, 0, /* 0 - 7 */ - 0, 0, ':', ';', '<', '=', '>', '?', /* 8 - ? */ - '@', -ESC_A, -ESC_B, -ESC_C, -ESC_D, -ESC_E, 0, -ESC_G, /* @ - G */ - 0, 0, 0, 0, 0, 0, 0, 0, /* H - O */ --ESC_P, -ESC_Q, 0, -ESC_S, 0, 0, 0, -ESC_W, /* P - W */ --ESC_X, 0, -ESC_Z, '[', '\\', ']', '^', '_', /* X - _ */ - '`', 7, -ESC_b, 0, -ESC_d, ESC_e, ESC_f, 0, /* ` - g */ - 0, 0, 0, 0, 0, 0, ESC_n, 0, /* h - o */ --ESC_p, 0, ESC_r, -ESC_s, ESC_tee, 0, 0, -ESC_w, /* p - w */ - 0, 0, -ESC_z /* x - z */ -}; - -#else /* This is the "abnormal" table for EBCDIC systems */ -static const short int escapes[] = { -/* 48 */ 0, 0, 0, '.', '<', '(', '+', '|', -/* 50 */ '&', 0, 0, 0, 0, 0, 0, 0, -/* 58 */ 0, 0, '!', '$', '*', ')', ';', '~', -/* 60 */ '-', '/', 0, 0, 0, 0, 0, 0, -/* 68 */ 0, 0, '|', ',', '%', '_', '>', '?', -/* 70 */ 0, 0, 0, 0, 0, 0, 0, 0, -/* 78 */ 0, '`', ':', '#', '@', '\'', '=', '"', -/* 80 */ 0, 7, -ESC_b, 0, -ESC_d, ESC_e, ESC_f, 0, -/* 88 */ 0, 0, 0, '{', 0, 0, 0, 0, -/* 90 */ 0, 0, 0, 'l', 0, ESC_n, 0, -ESC_p, -/* 98 */ 0, ESC_r, 0, '}', 0, 0, 0, 0, -/* A0 */ 0, '~', -ESC_s, ESC_tee, 0, 0, -ESC_w, 0, -/* A8 */ 0,-ESC_z, 0, 0, 0, '[', 0, 0, -/* B0 */ 0, 0, 0, 0, 0, 0, 0, 0, -/* B8 */ 0, 0, 0, 0, 0, ']', '=', '-', -/* C0 */ '{',-ESC_A, -ESC_B, -ESC_C, -ESC_D,-ESC_E, 0, -ESC_G, -/* C8 */ 0, 0, 0, 0, 0, 0, 0, 0, -/* D0 */ '}', 0, 0, 0, 0, 0, 0, -ESC_P, -/* D8 */-ESC_Q, 0, 0, 0, 0, 0, 0, 0, -/* E0 */ '\\', 0, -ESC_S, 0, 0, 0, -ESC_W, -ESC_X, -/* E8 */ 0,-ESC_Z, 0, 0, 0, 0, 0, 0, -/* F0 */ 0, 0, 0, 0, 0, 0, 0, 0, -/* F8 */ 0, 0, 0, 0, 0, 0, 0, 0 -}; -#endif - - -/* Tables of names of POSIX character classes and their lengths. The list is -terminated by a zero length entry. The first three must be alpha, upper, lower, -as this is assumed for handling case independence. */ - -static const char *const posix_names[] = { - "alpha", "lower", "upper", - "alnum", "ascii", "blank", "cntrl", "digit", "graph", - "print", "punct", "space", "word", "xdigit" }; - -static const uschar posix_name_lengths[] = { - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 4, 6, 0 }; - -/* Table of class bit maps for each POSIX class; up to three may be combined -to form the class. The table for [:blank:] is dynamically modified to remove -the vertical space characters. */ - -static const int posix_class_maps[] = { - cbit_lower, cbit_upper, -1, /* alpha */ - cbit_lower, -1, -1, /* lower */ - cbit_upper, -1, -1, /* upper */ - cbit_digit, cbit_lower, cbit_upper, /* alnum */ - cbit_print, cbit_cntrl, -1, /* ascii */ - cbit_space, -1, -1, /* blank - a GNU extension */ - cbit_cntrl, -1, -1, /* cntrl */ - cbit_digit, -1, -1, /* digit */ - cbit_graph, -1, -1, /* graph */ - cbit_print, -1, -1, /* print */ - cbit_punct, -1, -1, /* punct */ - cbit_space, -1, -1, /* space */ - cbit_word, -1, -1, /* word - a Perl extension */ - cbit_xdigit,-1, -1 /* xdigit */ -}; - -/* Table to identify digits and hex digits. This is used when compiling -patterns. Note that the tables in chartables are dependent on the locale, and -may mark arbitrary characters as digits - but the PCRE compiling code expects -to handle only 0-9, a-z, and A-Z as digits when compiling. That is why we have -a private table here. It costs 256 bytes, but it is a lot faster than doing -character value tests (at least in some simple cases I timed), and in some -applications one wants PCRE to compile efficiently as well as match -efficiently. - -For convenience, we use the same bit definitions as in chartables: - - 0x04 decimal digit - 0x08 hexadecimal digit - -Then we can use ctype_digit and ctype_xdigit in the code. */ - -#if !EBCDIC /* This is the "normal" case, for ASCII systems */ -static const unsigned char digitab[] = - { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 0- 7 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 8- 15 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 16- 23 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 24- 31 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* - ' */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* ( - / */ - 0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c, /* 0 - 7 */ - 0x0c,0x0c,0x00,0x00,0x00,0x00,0x00,0x00, /* 8 - ? */ - 0x00,0x08,0x08,0x08,0x08,0x08,0x08,0x00, /* @ - G */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* H - O */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* P - W */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* X - _ */ - 0x00,0x08,0x08,0x08,0x08,0x08,0x08,0x00, /* ` - g */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* h - o */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* p - w */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* x -127 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 128-135 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 136-143 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 144-151 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 152-159 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 160-167 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 168-175 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 176-183 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 184-191 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 192-199 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 200-207 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 208-215 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 216-223 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 224-231 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 232-239 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 240-247 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00};/* 248-255 */ - -#else /* This is the "abnormal" case, for EBCDIC systems */ -static const unsigned char digitab[] = - { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 0- 7 0 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 8- 15 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 16- 23 10 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 24- 31 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 32- 39 20 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 40- 47 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 48- 55 30 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 56- 63 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* - 71 40 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 72- | */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* & - 87 50 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 88- ¬ */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* - -103 60 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 104- ? */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 112-119 70 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 120- " */ - 0x00,0x08,0x08,0x08,0x08,0x08,0x08,0x00, /* 128- g 80 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* h -143 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 144- p 90 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* q -159 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 160- x A0 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* y -175 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* ^ -183 B0 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 184-191 */ - 0x00,0x08,0x08,0x08,0x08,0x08,0x08,0x00, /* { - G C0 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* H -207 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* } - P D0 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* Q -223 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* \ - X E0 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* Y -239 */ - 0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c, /* 0 - 7 F0 */ - 0x0c,0x0c,0x00,0x00,0x00,0x00,0x00,0x00};/* 8 -255 */ - -static const unsigned char ebcdic_chartab[] = { /* chartable partial dup */ - 0x80,0x00,0x00,0x00,0x00,0x01,0x00,0x00, /* 0- 7 */ - 0x00,0x00,0x00,0x00,0x01,0x01,0x00,0x00, /* 8- 15 */ - 0x00,0x00,0x00,0x00,0x00,0x01,0x00,0x00, /* 16- 23 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 24- 31 */ - 0x00,0x00,0x00,0x00,0x00,0x01,0x00,0x00, /* 32- 39 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 40- 47 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 48- 55 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 56- 63 */ - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* - 71 */ - 0x00,0x00,0x00,0x80,0x00,0x80,0x80,0x80, /* 72- | */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* & - 87 */ - 0x00,0x00,0x00,0x80,0x80,0x80,0x00,0x00, /* 88- ¬ */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* - -103 */ - 0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x80, /* 104- ? */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 112-119 */ - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* 120- " */ - 0x00,0x1a,0x1a,0x1a,0x1a,0x1a,0x1a,0x12, /* 128- g */ - 0x12,0x12,0x00,0x00,0x00,0x00,0x00,0x00, /* h -143 */ - 0x00,0x12,0x12,0x12,0x12,0x12,0x12,0x12, /* 144- p */ - 0x12,0x12,0x00,0x00,0x00,0x00,0x00,0x00, /* q -159 */ - 0x00,0x00,0x12,0x12,0x12,0x12,0x12,0x12, /* 160- x */ - 0x12,0x12,0x00,0x00,0x00,0x00,0x00,0x00, /* y -175 */ - 0x80,0x00,0x00,0x00,0x00,0x00,0x00,0x00, /* ^ -183 */ - 0x00,0x00,0x80,0x00,0x00,0x00,0x00,0x00, /* 184-191 */ - 0x80,0x1a,0x1a,0x1a,0x1a,0x1a,0x1a,0x12, /* { - G */ - 0x12,0x12,0x00,0x00,0x00,0x00,0x00,0x00, /* H -207 */ - 0x00,0x12,0x12,0x12,0x12,0x12,0x12,0x12, /* } - P */ - 0x12,0x12,0x00,0x00,0x00,0x00,0x00,0x00, /* Q -223 */ - 0x00,0x00,0x12,0x12,0x12,0x12,0x12,0x12, /* \ - X */ - 0x12,0x12,0x00,0x00,0x00,0x00,0x00,0x00, /* Y -239 */ - 0x1c,0x1c,0x1c,0x1c,0x1c,0x1c,0x1c,0x1c, /* 0 - 7 */ - 0x1c,0x1c,0x00,0x00,0x00,0x00,0x00,0x00};/* 8 -255 */ -#endif - - -/* Definition to allow mutual recursion */ - -static BOOL - compile_regex(int, int, int *, uschar **, const uschar **, const char **, - BOOL, int, int *, int *, branch_chain *, compile_data *); - -/* Structure for building a chain of data that actually lives on the -stack, for holding the values of the subject pointer at the start of each -subpattern, so as to detect when an empty string has been matched by a -subpattern - to break infinite loops. When NO_RECURSE is set, these blocks -are on the heap, not on the stack. */ - -typedef struct eptrblock { - struct eptrblock *epb_prev; - const uschar *epb_saved_eptr; -} eptrblock; - -/* Flag bits for the match() function */ - -#define match_condassert 0x01 /* Called to check a condition assertion */ -#define match_isgroup 0x02 /* Set if start of bracketed group */ - -/* Non-error returns from the match() function. Error returns are externally -defined PCRE_ERROR_xxx codes, which are all negative. */ - -#define MATCH_MATCH 1 -#define MATCH_NOMATCH 0 - - - -/************************************************* -* Global variables * -*************************************************/ - -/* PCRE is thread-clean and doesn't use any global variables in the normal -sense. However, it calls memory allocation and free functions via the four -indirections below, and it can optionally do callouts. These values can be -changed by the caller, but are shared between all threads. However, when -compiling for Virtual Pascal, things are done differently (see pcre.in). */ - -#ifndef VPCOMPAT -#ifdef __cplusplus -extern "C" void *(*pcre_malloc)(size_t) = malloc; -extern "C" void (*pcre_free)(void *) = free; -extern "C" void *(*pcre_stack_malloc)(size_t) = malloc; -extern "C" void (*pcre_stack_free)(void *) = free; -extern "C" int (*pcre_callout)(pcre_callout_block *) = NULL; -#else -void *(*pcre_malloc)(size_t) = malloc; -void (*pcre_free)(void *) = free; -void *(*pcre_stack_malloc)(size_t) = malloc; -void (*pcre_stack_free)(void *) = free; -int (*pcre_callout)(pcre_callout_block *) = NULL; -#endif -#endif - - -/************************************************* -* Macros and tables for character handling * -*************************************************/ - -/* When UTF-8 encoding is being used, a character is no longer just a single -byte. The macros for character handling generate simple sequences when used in -byte-mode, and more complicated ones for UTF-8 characters. */ - -#ifndef SUPPORT_UTF8 -#define GETCHAR(c, eptr) c = *eptr; -#define GETCHARINC(c, eptr) c = *eptr++; -#define GETCHARINCTEST(c, eptr) c = *eptr++; -#define GETCHARLEN(c, eptr, len) c = *eptr; -#define BACKCHAR(eptr) - -#else /* SUPPORT_UTF8 */ - -/* Get the next UTF-8 character, not advancing the pointer. This is called when -we know we are in UTF-8 mode. */ - -#define GETCHAR(c, eptr) \ - c = *eptr; \ - if ((c & 0xc0) == 0xc0) \ - { \ - int gcii; \ - int gcaa = utf8_table4[c & 0x3f]; /* Number of additional bytes */ \ - int gcss = 6*gcaa; \ - c = (c & utf8_table3[gcaa]) << gcss; \ - for (gcii = 1; gcii <= gcaa; gcii++) \ - { \ - gcss -= 6; \ - c |= (eptr[gcii] & 0x3f) << gcss; \ - } \ - } - -/* Get the next UTF-8 character, advancing the pointer. This is called when we -know we are in UTF-8 mode. */ - -#define GETCHARINC(c, eptr) \ - c = *eptr++; \ - if ((c & 0xc0) == 0xc0) \ - { \ - int gcaa = utf8_table4[c & 0x3f]; /* Number of additional bytes */ \ - int gcss = 6*gcaa; \ - c = (c & utf8_table3[gcaa]) << gcss; \ - while (gcaa-- > 0) \ - { \ - gcss -= 6; \ - c |= (*eptr++ & 0x3f) << gcss; \ - } \ - } - -/* Get the next character, testing for UTF-8 mode, and advancing the pointer */ - -#define GETCHARINCTEST(c, eptr) \ - c = *eptr++; \ - if (md->utf8 && (c & 0xc0) == 0xc0) \ - { \ - int gcaa = utf8_table4[c & 0x3f]; /* Number of additional bytes */ \ - int gcss = 6*gcaa; \ - c = (c & utf8_table3[gcaa]) << gcss; \ - while (gcaa-- > 0) \ - { \ - gcss -= 6; \ - c |= (*eptr++ & 0x3f) << gcss; \ - } \ - } - -/* Get the next UTF-8 character, not advancing the pointer, incrementing length -if there are extra bytes. This is called when we know we are in UTF-8 mode. */ - -#define GETCHARLEN(c, eptr, len) \ - c = *eptr; \ - if ((c & 0xc0) == 0xc0) \ - { \ - int gcii; \ - int gcaa = utf8_table4[c & 0x3f]; /* Number of additional bytes */ \ - int gcss = 6*gcaa; \ - c = (c & utf8_table3[gcaa]) << gcss; \ - for (gcii = 1; gcii <= gcaa; gcii++) \ - { \ - gcss -= 6; \ - c |= (eptr[gcii] & 0x3f) << gcss; \ - } \ - len += gcaa; \ - } - -/* If the pointer is not at the start of a character, move it back until -it is. Called only in UTF-8 mode. */ - -#define BACKCHAR(eptr) while((*eptr & 0xc0) == 0x80) eptr--; - -#endif - - - -/************************************************* -* Default character tables * -*************************************************/ - -/* A default set of character tables is included in the PCRE binary. Its source -is built by the maketables auxiliary program, which uses the default C ctypes -functions, and put in the file chartables.c. These tables are used by PCRE -whenever the caller of pcre_compile() does not provide an alternate set of -tables. */ - -#include "pcre-chartables.c" - - - -#ifdef SUPPORT_UTF8 -/************************************************* -* Tables for UTF-8 support * -*************************************************/ - -/* These are the breakpoints for different numbers of bytes in a UTF-8 -character. */ - -static const int utf8_table1[] = - { 0x7f, 0x7ff, 0xffff, 0x1fffff, 0x3ffffff, 0x7fffffff}; - -/* These are the indicator bits and the mask for the data bits to set in the -first byte of a character, indexed by the number of additional bytes. */ - -static const int utf8_table2[] = { 0, 0xc0, 0xe0, 0xf0, 0xf8, 0xfc}; -static const int utf8_table3[] = { 0xff, 0x1f, 0x0f, 0x07, 0x03, 0x01}; - -/* Table of the number of extra characters, indexed by the first character -masked with 0x3f. The highest number for a valid UTF-8 character is in fact -0x3d. */ - -static const uschar utf8_table4[] = { - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5 }; - - -/************************************************* -* Convert character value to UTF-8 * -*************************************************/ - -/* This function takes an integer value in the range 0 - 0x7fffffff -and encodes it as a UTF-8 character in 0 to 6 bytes. - -Arguments: - cvalue the character value - buffer pointer to buffer for result - at least 6 bytes long - -Returns: number of characters placed in the buffer -*/ - -static int -ord2utf8(int cvalue, uschar *buffer) -{ -register int i, j; -for (i = 0; i < sizeof(utf8_table1)/sizeof(int); i++) - if (cvalue <= utf8_table1[i]) break; -buffer += i; -for (j = i; j > 0; j--) - { - *buffer-- = 0x80 | (cvalue & 0x3f); - cvalue >>= 6; - } -*buffer = utf8_table2[i] | cvalue; -return i + 1; -} -#endif - - - -/************************************************* -* Print compiled regex * -*************************************************/ - -/* The code for doing this is held in a separate file that is also included in -pcretest.c. It defines a function called print_internals(). */ - -#ifdef DEBUG_PCRE -#include "printint.c" -#endif - - - -/************************************************* -* Return version string * -*************************************************/ - -#define STRING(a) # a -#define XSTRING(s) STRING(s) - -EXPORT const char * -pcre_version(void) -{ -return XSTRING(PCRE_MAJOR) "." XSTRING(PCRE_MINOR) " " XSTRING(PCRE_DATE); -} - - - - -/************************************************* -* Flip bytes in an integer * -*************************************************/ - -/* This function is called when the magic number in a regex doesn't match in -order to flip its bytes to see if we are dealing with a pattern that was -compiled on a host of different endianness. If so, this function is used to -flip other byte values. - -Arguments: - value the number to flip - n the number of bytes to flip (assumed to be 2 or 4) - -Returns: the flipped value -*/ - -static long int -byteflip(long int value, int n) -{ -if (n == 2) return ((value & 0x00ff) << 8) | ((value & 0xff00) >> 8); -return ((value & 0x000000ff) << 24) | - ((value & 0x0000ff00) << 8) | - ((value & 0x00ff0000) >> 8) | - ((value & 0xff000000) >> 24); -} - - - -/************************************************* -* Test for a byte-flipped compiled regex * -*************************************************/ - -/* This function is called from pce_exec() and also from pcre_fullinfo(). Its -job is to test whether the regex is byte-flipped - that is, it was compiled on -a system of opposite endianness. The function is called only when the native -MAGIC_NUMBER test fails. If the regex is indeed flipped, we flip all the -relevant values into a different data block, and return it. - -Arguments: - re points to the regex - study points to study data, or NULL - internal_re points to a new regex block - internal_study points to a new study block - -Returns: the new block if is is indeed a byte-flipped regex - NULL if it is not -*/ - -static real_pcre * -try_flipped(const real_pcre *re, real_pcre *internal_re, - const pcre_study_data *study, pcre_study_data *internal_study) -{ -if (byteflip(re->magic_number, sizeof(re->magic_number)) != MAGIC_NUMBER) - return NULL; - -*internal_re = *re; /* To copy other fields */ -internal_re->size = byteflip(re->size, sizeof(re->size)); -internal_re->options = byteflip(re->options, sizeof(re->options)); -internal_re->top_bracket = byteflip(re->top_bracket, sizeof(re->top_bracket)); -internal_re->top_backref = byteflip(re->top_backref, sizeof(re->top_backref)); -internal_re->first_byte = byteflip(re->first_byte, sizeof(re->first_byte)); -internal_re->req_byte = byteflip(re->req_byte, sizeof(re->req_byte)); -internal_re->name_table_offset = byteflip(re->name_table_offset, - sizeof(re->name_table_offset)); -internal_re->name_entry_size = byteflip(re->name_entry_size, - sizeof(re->name_entry_size)); -internal_re->name_count = byteflip(re->name_count, sizeof(re->name_count)); - -if (study != NULL) - { - *internal_study = *study; /* To copy other fields */ - internal_study->size = byteflip(study->size, sizeof(study->size)); - internal_study->options = byteflip(study->options, sizeof(study->options)); - } - -return internal_re; -} - - - -/************************************************* -* (Obsolete) Return info about compiled pattern * -*************************************************/ - -/* This is the original "info" function. It picks potentially useful data out -of the private structure, but its interface was too rigid. It remains for -backwards compatibility. The public options are passed back in an int - though -the re->options field has been expanded to a long int, all the public options -at the low end of it, and so even on 16-bit systems this will still be OK. -Therefore, I haven't changed the API for pcre_info(). - -Arguments: - argument_re points to compiled code - optptr where to pass back the options - first_byte where to pass back the first character, - or -1 if multiline and all branches start ^, - or -2 otherwise - -Returns: number of capturing subpatterns - or negative values on error -*/ - -EXPORT int -pcre_info(const pcre *argument_re, int *optptr, int *first_byte) -{ -real_pcre internal_re; -const real_pcre *re = (const real_pcre *)argument_re; -if (re == NULL) return PCRE_ERROR_NULL; -if (re->magic_number != MAGIC_NUMBER) - { - re = try_flipped(re, &internal_re, NULL, NULL); - if (re == NULL) return PCRE_ERROR_BADMAGIC; - } -if (optptr != NULL) *optptr = (int)(re->options & PUBLIC_OPTIONS); -if (first_byte != NULL) - *first_byte = ((re->options & PCRE_FIRSTSET) != 0)? re->first_byte : - ((re->options & PCRE_STARTLINE) != 0)? -1 : -2; -return re->top_bracket; -} - - - -/************************************************* -* Return info about compiled pattern * -*************************************************/ - -/* This is a newer "info" function which has an extensible interface so -that additional items can be added compatibly. - -Arguments: - argument_re points to compiled code - extra_data points extra data, or NULL - what what information is required - where where to put the information - -Returns: 0 if data returned, negative on error -*/ - -EXPORT int -pcre_fullinfo(const pcre *argument_re, const pcre_extra *extra_data, int what, - void *where) -{ -real_pcre internal_re; -pcre_study_data internal_study; -const real_pcre *re = (const real_pcre *)argument_re; -const pcre_study_data *study = NULL; - -if (re == NULL || where == NULL) return PCRE_ERROR_NULL; - -if (extra_data != NULL && (extra_data->flags & PCRE_EXTRA_STUDY_DATA) != 0) - study = (const pcre_study_data *)extra_data->study_data; - -if (re->magic_number != MAGIC_NUMBER) - { - re = try_flipped(re, &internal_re, study, &internal_study); - if (re == NULL) return PCRE_ERROR_BADMAGIC; - if (study != NULL) study = &internal_study; - } - -switch (what) - { - case PCRE_INFO_OPTIONS: - *((unsigned long int *)where) = re->options & PUBLIC_OPTIONS; - break; - - case PCRE_INFO_SIZE: - *((size_t *)where) = re->size; - break; - - case PCRE_INFO_STUDYSIZE: - *((size_t *)where) = (study == NULL)? 0 : study->size; - break; - - case PCRE_INFO_CAPTURECOUNT: - *((int *)where) = re->top_bracket; - break; - - case PCRE_INFO_BACKREFMAX: - *((int *)where) = re->top_backref; - break; - - case PCRE_INFO_FIRSTBYTE: - *((int *)where) = - ((re->options & PCRE_FIRSTSET) != 0)? re->first_byte : - ((re->options & PCRE_STARTLINE) != 0)? -1 : -2; - break; - - /* Make sure we pass back the pointer to the bit vector in the external - block, not the internal copy (with flipped integer fields). */ - - case PCRE_INFO_FIRSTTABLE: - *((const uschar **)where) = - (study != NULL && (study->options & PCRE_STUDY_MAPPED) != 0)? - ((const pcre_study_data *)extra_data->study_data)->start_bits : NULL; - break; - - case PCRE_INFO_LASTLITERAL: - *((int *)where) = - ((re->options & PCRE_REQCHSET) != 0)? re->req_byte : -1; - break; - - case PCRE_INFO_NAMEENTRYSIZE: - *((int *)where) = re->name_entry_size; - break; - - case PCRE_INFO_NAMECOUNT: - *((int *)where) = re->name_count; - break; - - case PCRE_INFO_NAMETABLE: - *((const uschar **)where) = (const uschar *)re + re->name_table_offset; - break; - - case PCRE_INFO_DEFAULT_TABLES: - *((const uschar **)where) = (const uschar *)pcre_default_tables; - break; - - default: return PCRE_ERROR_BADOPTION; - } - -return 0; -} - - - -/************************************************* -* Return info about what features are configured * -*************************************************/ - -/* This is function which has an extensible interface so that additional items -can be added compatibly. - -Arguments: - what what information is required - where where to put the information - -Returns: 0 if data returned, negative on error -*/ - -EXPORT int -pcre_config(int what, void *where) -{ -switch (what) - { - case PCRE_CONFIG_UTF8: -#ifdef SUPPORT_UTF8 - *((int *)where) = 1; -#else - *((int *)where) = 0; -#endif - break; - - case PCRE_CONFIG_UNICODE_PROPERTIES: -#ifdef SUPPORT_UCP - *((int *)where) = 1; -#else - *((int *)where) = 0; -#endif - break; - - case PCRE_CONFIG_NEWLINE: - *((int *)where) = NEWLINE; - break; - - case PCRE_CONFIG_LINK_SIZE: - *((int *)where) = LINK_SIZE; - break; - - case PCRE_CONFIG_POSIX_MALLOC_THRESHOLD: - *((int *)where) = POSIX_MALLOC_THRESHOLD; - break; - - case PCRE_CONFIG_MATCH_LIMIT: - *((unsigned int *)where) = MATCH_LIMIT; - break; - - case PCRE_CONFIG_STACKRECURSE: -#ifdef NO_RECURSE - *((int *)where) = 0; -#else - *((int *)where) = 1; -#endif - break; - - default: return PCRE_ERROR_BADOPTION; - } - -return 0; -} - - - -#ifdef DEBUG -/************************************************* -* Debugging function to print chars * -*************************************************/ - -/* Print a sequence of chars in printable format, stopping at the end of the -subject if the requested. - -Arguments: - p points to characters - length number to print - is_subject TRUE if printing from within md->start_subject - md pointer to matching data block, if is_subject is TRUE - -Returns: nothing -*/ - -static void -pchars(const uschar *p, int length, BOOL is_subject, match_data *md) -{ -int c; -if (is_subject && length > md->end_subject - p) length = md->end_subject - p; -while (length-- > 0) - if (isprint(c = *(p++))) printf("%c", c); else printf("\\x%02x", c); -} -#endif - - - - -/************************************************* -* Handle escapes * -*************************************************/ - -/* This function is called when a \ has been encountered. It either returns a -positive value for a simple escape such as \n, or a negative value which -encodes one of the more complicated things such as \d. When UTF-8 is enabled, -a positive value greater than 255 may be returned. On entry, ptr is pointing at -the \. On exit, it is on the final character of the escape sequence. - -Arguments: - ptrptr points to the pattern position pointer - errorptr points to the pointer to the error message - bracount number of previous extracting brackets - options the options bits - isclass TRUE if inside a character class - -Returns: zero or positive => a data character - negative => a special escape sequence - on error, errorptr is set -*/ - -static int -check_escape(const uschar **ptrptr, const char **errorptr, int bracount, - int options, BOOL isclass) -{ -const uschar *ptr = *ptrptr; -int c, i; - -/* If backslash is at the end of the pattern, it's an error. */ - -c = *(++ptr); -if (c == 0) *errorptr = ERR1; - -/* Non-alphamerics are literals. For digits or letters, do an initial lookup in -a table. A non-zero result is something that can be returned immediately. -Otherwise further processing may be required. */ - -#if !EBCDIC /* ASCII coding */ -else if (c < '0' || c > 'z') {} /* Not alphameric */ -else if ((i = escapes[c - '0']) != 0) c = i; - -#else /* EBCDIC coding */ -else if (c < 'a' || (ebcdic_chartab[c] & 0x0E) == 0) {} /* Not alphameric */ -else if ((i = escapes[c - 0x48]) != 0) c = i; -#endif - -/* Escapes that need further processing, or are illegal. */ - -else - { - const uschar *oldptr; - switch (c) - { - /* A number of Perl escapes are not handled by PCRE. We give an explicit - error. */ - - case 'l': - case 'L': - case 'N': - case 'u': - case 'U': - *errorptr = ERR37; - break; - - /* The handling of escape sequences consisting of a string of digits - starting with one that is not zero is not straightforward. By experiment, - the way Perl works seems to be as follows: - - Outside a character class, the digits are read as a decimal number. If the - number is less than 10, or if there are that many previous extracting - left brackets, then it is a back reference. Otherwise, up to three octal - digits are read to form an escaped byte. Thus \123 is likely to be octal - 123 (cf \0123, which is octal 012 followed by the literal 3). If the octal - value is greater than 377, the least significant 8 bits are taken. Inside a - character class, \ followed by a digit is always an octal number. */ - - case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - - if (!isclass) - { - oldptr = ptr; - c -= '0'; - while ((digitab[ptr[1]] & ctype_digit) != 0) - c = c * 10 + *(++ptr) - '0'; - if (c < 10 || c <= bracount) - { - c = -(ESC_REF + c); - break; - } - ptr = oldptr; /* Put the pointer back and fall through */ - } - - /* Handle an octal number following \. If the first digit is 8 or 9, Perl - generates a binary zero byte and treats the digit as a following literal. - Thus we have to pull back the pointer by one. */ - - if ((c = *ptr) >= '8') - { - ptr--; - c = 0; - break; - } - - /* \0 always starts an octal number, but we may drop through to here with a - larger first octal digit. */ - - case '0': - c -= '0'; - while(i++ < 2 && ptr[1] >= '0' && ptr[1] <= '7') - c = c * 8 + *(++ptr) - '0'; - c &= 255; /* Take least significant 8 bits */ - break; - - /* \x is complicated when UTF-8 is enabled. \x{ddd} is a character number - which can be greater than 0xff, but only if the ddd are hex digits. */ - - case 'x': -#ifdef SUPPORT_UTF8 - if (ptr[1] == '{' && (options & PCRE_UTF8) != 0) - { - const uschar *pt = ptr + 2; - register int count = 0; - c = 0; - while ((digitab[*pt] & ctype_xdigit) != 0) - { - int cc = *pt++; - count++; -#if !EBCDIC /* ASCII coding */ - if (cc >= 'a') cc -= 32; /* Convert to upper case */ - c = c * 16 + cc - ((cc < 'A')? '0' : ('A' - 10)); -#else /* EBCDIC coding */ - if (cc >= 'a' && cc <= 'z') cc += 64; /* Convert to upper case */ - c = c * 16 + cc - ((cc >= '0')? '0' : ('A' - 10)); -#endif - } - if (*pt == '}') - { - if (c < 0 || count > 8) *errorptr = ERR34; - ptr = pt; - break; - } - /* If the sequence of hex digits does not end with '}', then we don't - recognize this construct; fall through to the normal \x handling. */ - } -#endif - - /* Read just a single hex char */ - - c = 0; - while (i++ < 2 && (digitab[ptr[1]] & ctype_xdigit) != 0) - { - int cc; /* Some compilers don't like ++ */ - cc = *(++ptr); /* in initializers */ -#if !EBCDIC /* ASCII coding */ - if (cc >= 'a') cc -= 32; /* Convert to upper case */ - c = c * 16 + cc - ((cc < 'A')? '0' : ('A' - 10)); -#else /* EBCDIC coding */ - if (cc <= 'z') cc += 64; /* Convert to upper case */ - c = c * 16 + cc - ((cc >= '0')? '0' : ('A' - 10)); -#endif - } - break; - - /* Other special escapes not starting with a digit are straightforward */ - - case 'c': - c = *(++ptr); - if (c == 0) - { - *errorptr = ERR2; - return 0; - } - - /* A letter is upper-cased; then the 0x40 bit is flipped. This coding - is ASCII-specific, but then the whole concept of \cx is ASCII-specific. - (However, an EBCDIC equivalent has now been added.) */ - -#if !EBCDIC /* ASCII coding */ - if (c >= 'a' && c <= 'z') c -= 32; - c ^= 0x40; -#else /* EBCDIC coding */ - if (c >= 'a' && c <= 'z') c += 64; - c ^= 0xC0; -#endif - break; - - /* PCRE_EXTRA enables extensions to Perl in the matter of escapes. Any - other alphameric following \ is an error if PCRE_EXTRA was set; otherwise, - for Perl compatibility, it is a literal. This code looks a bit odd, but - there used to be some cases other than the default, and there may be again - in future, so I haven't "optimized" it. */ - - default: - if ((options & PCRE_EXTRA) != 0) switch(c) - { - default: - *errorptr = ERR3; - break; - } - break; - } - } - -*ptrptr = ptr; -return c; -} - - - -#ifdef SUPPORT_UCP -/************************************************* -* Handle \P and \p * -*************************************************/ - -/* This function is called after \P or \p has been encountered, provided that -PCRE is compiled with support for Unicode properties. On entry, ptrptr is -pointing at the P or p. On exit, it is pointing at the final character of the -escape sequence. - -Argument: - ptrptr points to the pattern position pointer - negptr points to a boolean that is set TRUE for negation else FALSE - errorptr points to the pointer to the error message - -Returns: value from ucp_type_table, or -1 for an invalid type -*/ - -static int -get_ucp(const uschar **ptrptr, BOOL *negptr, const char **errorptr) -{ -int c, i, bot, top; -const uschar *ptr = *ptrptr; -char name[4]; - -c = *(++ptr); -if (c == 0) goto ERROR_RETURN; - -*negptr = FALSE; - -/* \P or \p can be followed by a one- or two-character name in {}, optionally -preceded by ^ for negation. */ - -if (c == '{') - { - if (ptr[1] == '^') - { - *negptr = TRUE; - ptr++; - } - for (i = 0; i <= 2; i++) - { - c = *(++ptr); - if (c == 0) goto ERROR_RETURN; - if (c == '}') break; - name[i] = c; - } - if (c !='}') /* Try to distinguish error cases */ - { - while (*(++ptr) != 0 && *ptr != '}'); - if (*ptr == '}') goto UNKNOWN_RETURN; else goto ERROR_RETURN; - } - name[i] = 0; - } - -/* Otherwise there is just one following character */ - -else - { - name[0] = c; - name[1] = 0; - } - -*ptrptr = ptr; - -/* Search for a recognized property name using binary chop */ - -bot = 0; -top = sizeof(utt)/sizeof(ucp_type_table); - -while (bot < top) - { - i = (bot + top)/2; - c = strcmp(name, utt[i].name); - if (c == 0) return utt[i].value; - if (c > 0) bot = i + 1; else top = i; - } - -UNKNOWN_RETURN: -*errorptr = ERR47; -*ptrptr = ptr; -return -1; - -ERROR_RETURN: -*errorptr = ERR46; -*ptrptr = ptr; -return -1; -} -#endif - - - - -/************************************************* -* Check for counted repeat * -*************************************************/ - -/* This function is called when a '{' is encountered in a place where it might -start a quantifier. It looks ahead to see if it really is a quantifier or not. -It is only a quantifier if it is one of the forms {ddd} {ddd,} or {ddd,ddd} -where the ddds are digits. - -Arguments: - p pointer to the first char after '{' - -Returns: TRUE or FALSE -*/ - -static BOOL -is_counted_repeat(const uschar *p) -{ -if ((digitab[*p++] & ctype_digit) == 0) return FALSE; -while ((digitab[*p] & ctype_digit) != 0) p++; -if (*p == '}') return TRUE; - -if (*p++ != ',') return FALSE; -if (*p == '}') return TRUE; - -if ((digitab[*p++] & ctype_digit) == 0) return FALSE; -while ((digitab[*p] & ctype_digit) != 0) p++; - -return (*p == '}'); -} - - - -/************************************************* -* Read repeat counts * -*************************************************/ - -/* Read an item of the form {n,m} and return the values. This is called only -after is_counted_repeat() has confirmed that a repeat-count quantifier exists, -so the syntax is guaranteed to be correct, but we need to check the values. - -Arguments: - p pointer to first char after '{' - minp pointer to int for min - maxp pointer to int for max - returned as -1 if no max - errorptr points to pointer to error message - -Returns: pointer to '}' on success; - current ptr on error, with errorptr set -*/ - -static const uschar * -read_repeat_counts(const uschar *p, int *minp, int *maxp, const char **errorptr) -{ -int min = 0; -int max = -1; - -while ((digitab[*p] & ctype_digit) != 0) min = min * 10 + *p++ - '0'; - -if (*p == '}') max = min; else - { - if (*(++p) != '}') - { - max = 0; - while((digitab[*p] & ctype_digit) != 0) max = max * 10 + *p++ - '0'; - if (max < min) - { - *errorptr = ERR4; - return p; - } - } - } - -/* Do paranoid checks, then fill in the required variables, and pass back the -pointer to the terminating '}'. */ - -if (min > 65535 || max > 65535) - *errorptr = ERR5; -else - { - *minp = min; - *maxp = max; - } -return p; -} - - - -/************************************************* -* Find first significant op code * -*************************************************/ - -/* This is called by several functions that scan a compiled expression looking -for a fixed first character, or an anchoring op code etc. It skips over things -that do not influence this. For some calls, a change of option is important. -For some calls, it makes sense to skip negative forward and all backward -assertions, and also the \b assertion; for others it does not. - -Arguments: - code pointer to the start of the group - options pointer to external options - optbit the option bit whose changing is significant, or - zero if none are - skipassert TRUE if certain assertions are to be skipped - -Returns: pointer to the first significant opcode -*/ - -static const uschar* -first_significant_code(const uschar *code, int *options, int optbit, - BOOL skipassert) -{ -for (;;) - { - switch ((int)*code) - { - case OP_OPT: - if (optbit > 0 && ((int)code[1] & optbit) != (*options & optbit)) - *options = (int)code[1]; - code += 2; - break; - - case OP_ASSERT_NOT: - case OP_ASSERTBACK: - case OP_ASSERTBACK_NOT: - if (!skipassert) return code; - do code += GET(code, 1); while (*code == OP_ALT); - code += OP_lengths[*code]; - break; - - case OP_WORD_BOUNDARY: - case OP_NOT_WORD_BOUNDARY: - if (!skipassert) return code; - /* Fall through */ - - case OP_CALLOUT: - case OP_CREF: - case OP_BRANUMBER: - code += OP_lengths[*code]; - break; - - default: - return code; - } - } -/* Control never reaches here */ -} - - - - -/************************************************* -* Find the fixed length of a pattern * -*************************************************/ - -/* Scan a pattern and compute the fixed length of subject that will match it, -if the length is fixed. This is needed for dealing with backward assertions. -In UTF8 mode, the result is in characters rather than bytes. - -Arguments: - code points to the start of the pattern (the bracket) - options the compiling options - -Returns: the fixed length, or -1 if there is no fixed length, - or -2 if \C was encountered -*/ - -static int -find_fixedlength(uschar *code, int options) -{ -int length = -1; - -register int branchlength = 0; -register uschar *cc = code + 1 + LINK_SIZE; - -/* Scan along the opcodes for this branch. If we get to the end of the -branch, check the length against that of the other branches. */ - -for (;;) - { - int d; - register int op = *cc; - if (op >= OP_BRA) op = OP_BRA; - - switch (op) - { - case OP_BRA: - case OP_ONCE: - case OP_COND: - d = find_fixedlength(cc, options); - if (d < 0) return d; - branchlength += d; - do cc += GET(cc, 1); while (*cc == OP_ALT); - cc += 1 + LINK_SIZE; - break; - - /* Reached end of a branch; if it's a ket it is the end of a nested - call. If it's ALT it is an alternation in a nested call. If it is - END it's the end of the outer call. All can be handled by the same code. */ - - case OP_ALT: - case OP_KET: - case OP_KETRMAX: - case OP_KETRMIN: - case OP_END: - if (length < 0) length = branchlength; - else if (length != branchlength) return -1; - if (*cc != OP_ALT) return length; - cc += 1 + LINK_SIZE; - branchlength = 0; - break; - - /* Skip over assertive subpatterns */ - - case OP_ASSERT: - case OP_ASSERT_NOT: - case OP_ASSERTBACK: - case OP_ASSERTBACK_NOT: - do cc += GET(cc, 1); while (*cc == OP_ALT); - /* Fall through */ - - /* Skip over things that don't match chars */ - - case OP_REVERSE: - case OP_BRANUMBER: - case OP_CREF: - case OP_OPT: - case OP_CALLOUT: - case OP_SOD: - case OP_SOM: - case OP_EOD: - case OP_EODN: - case OP_CIRC: - case OP_DOLL: - case OP_NOT_WORD_BOUNDARY: - case OP_WORD_BOUNDARY: - cc += OP_lengths[*cc]; - break; - - /* Handle literal characters */ - - case OP_CHAR: - case OP_CHARNC: - branchlength++; - cc += 2; -#ifdef SUPPORT_UTF8 - if ((options & PCRE_UTF8) != 0) - { - while ((*cc & 0xc0) == 0x80) cc++; - } -#endif - break; - - /* Handle exact repetitions. The count is already in characters, but we - need to skip over a multibyte character in UTF8 mode. */ - - case OP_EXACT: - branchlength += GET2(cc,1); - cc += 4; -#ifdef SUPPORT_UTF8 - if ((options & PCRE_UTF8) != 0) - { - while((*cc & 0x80) == 0x80) cc++; - } -#endif - break; - - case OP_TYPEEXACT: - branchlength += GET2(cc,1); - cc += 4; - break; - - /* Handle single-char matchers */ - - case OP_PROP: - case OP_NOTPROP: - cc++; - /* Fall through */ - - case OP_NOT_DIGIT: - case OP_DIGIT: - case OP_NOT_WHITESPACE: - case OP_WHITESPACE: - case OP_NOT_WORDCHAR: - case OP_WORDCHAR: - case OP_ANY: - branchlength++; - cc++; - break; - - /* The single-byte matcher isn't allowed */ - - case OP_ANYBYTE: - return -2; - - /* Check a class for variable quantification */ - -#ifdef SUPPORT_UTF8 - case OP_XCLASS: - cc += GET(cc, 1) - 33; - /* Fall through */ -#endif - - case OP_CLASS: - case OP_NCLASS: - cc += 33; - - switch (*cc) - { - case OP_CRSTAR: - case OP_CRMINSTAR: - case OP_CRQUERY: - case OP_CRMINQUERY: - return -1; - - case OP_CRRANGE: - case OP_CRMINRANGE: - if (GET2(cc,1) != GET2(cc,3)) return -1; - branchlength += GET2(cc,1); - cc += 5; - break; - - default: - branchlength++; - } - break; - - /* Anything else is variable length */ - - default: - return -1; - } - } -/* Control never gets here */ -} - - - - -/************************************************* -* Scan compiled regex for numbered bracket * -*************************************************/ - -/* This little function scans through a compiled pattern until it finds a -capturing bracket with the given number. - -Arguments: - code points to start of expression - utf8 TRUE in UTF-8 mode - number the required bracket number - -Returns: pointer to the opcode for the bracket, or NULL if not found -*/ - -static const uschar * -find_bracket(const uschar *code, BOOL utf8, int number) -{ -#ifndef SUPPORT_UTF8 -utf8 = utf8; /* Stop pedantic compilers complaining */ -#endif - -for (;;) - { - register int c = *code; - if (c == OP_END) return NULL; - else if (c > OP_BRA) - { - int n = c - OP_BRA; - if (n > EXTRACT_BASIC_MAX) n = GET2(code, 2+LINK_SIZE); - if (n == number) return (uschar *)code; - code += OP_lengths[OP_BRA]; - } - else - { - code += OP_lengths[c]; - -#ifdef SUPPORT_UTF8 - - /* In UTF-8 mode, opcodes that are followed by a character may be followed - by a multi-byte character. The length in the table is a minimum, so we have - to scan along to skip the extra bytes. All opcodes are less than 128, so we - can use relatively efficient code. */ - - if (utf8) switch(c) - { - case OP_CHAR: - case OP_CHARNC: - case OP_EXACT: - case OP_UPTO: - case OP_MINUPTO: - case OP_STAR: - case OP_MINSTAR: - case OP_PLUS: - case OP_MINPLUS: - case OP_QUERY: - case OP_MINQUERY: - while ((*code & 0xc0) == 0x80) code++; - break; - - /* XCLASS is used for classes that cannot be represented just by a bit - map. This includes negated single high-valued characters. The length in - the table is zero; the actual length is stored in the compiled code. */ - - case OP_XCLASS: - code += GET(code, 1) + 1; - break; - } -#endif - } - } -} - - - -/************************************************* -* Scan compiled regex for recursion reference * -*************************************************/ - -/* This little function scans through a compiled pattern until it finds an -instance of OP_RECURSE. - -Arguments: - code points to start of expression - utf8 TRUE in UTF-8 mode - -Returns: pointer to the opcode for OP_RECURSE, or NULL if not found -*/ - -static const uschar * -find_recurse(const uschar *code, BOOL utf8) -{ -#ifndef SUPPORT_UTF8 -utf8 = utf8; /* Stop pedantic compilers complaining */ -#endif - -for (;;) - { - register int c = *code; - if (c == OP_END) return NULL; - else if (c == OP_RECURSE) return code; - else if (c > OP_BRA) - { - code += OP_lengths[OP_BRA]; - } - else - { - code += OP_lengths[c]; - -#ifdef SUPPORT_UTF8 - - /* In UTF-8 mode, opcodes that are followed by a character may be followed - by a multi-byte character. The length in the table is a minimum, so we have - to scan along to skip the extra bytes. All opcodes are less than 128, so we - can use relatively efficient code. */ - - if (utf8) switch(c) - { - case OP_CHAR: - case OP_CHARNC: - case OP_EXACT: - case OP_UPTO: - case OP_MINUPTO: - case OP_STAR: - case OP_MINSTAR: - case OP_PLUS: - case OP_MINPLUS: - case OP_QUERY: - case OP_MINQUERY: - while ((*code & 0xc0) == 0x80) code++; - break; - - /* XCLASS is used for classes that cannot be represented just by a bit - map. This includes negated single high-valued characters. The length in - the table is zero; the actual length is stored in the compiled code. */ - - case OP_XCLASS: - code += GET(code, 1) + 1; - break; - } -#endif - } - } -} - - - -/************************************************* -* Scan compiled branch for non-emptiness * -*************************************************/ - -/* This function scans through a branch of a compiled pattern to see whether it -can match the empty string or not. It is called only from could_be_empty() -below. Note that first_significant_code() skips over assertions. If we hit an -unclosed bracket, we return "empty" - this means we've struck an inner bracket -whose current branch will already have been scanned. - -Arguments: - code points to start of search - endcode points to where to stop - utf8 TRUE if in UTF8 mode - -Returns: TRUE if what is matched could be empty -*/ - -static BOOL -could_be_empty_branch(const uschar *code, const uschar *endcode, BOOL utf8) -{ -register int c; -for (code = first_significant_code(code + 1 + LINK_SIZE, NULL, 0, TRUE); - code < endcode; - code = first_significant_code(code + OP_lengths[c], NULL, 0, TRUE)) - { - const uschar *ccode; - - c = *code; - - if (c >= OP_BRA) - { - BOOL empty_branch; - if (GET(code, 1) == 0) return TRUE; /* Hit unclosed bracket */ - - /* Scan a closed bracket */ - - empty_branch = FALSE; - do - { - if (!empty_branch && could_be_empty_branch(code, endcode, utf8)) - empty_branch = TRUE; - code += GET(code, 1); - } - while (*code == OP_ALT); - if (!empty_branch) return FALSE; /* All branches are non-empty */ - code += 1 + LINK_SIZE; - c = *code; - } - - else switch (c) - { - /* Check for quantifiers after a class */ - -#ifdef SUPPORT_UTF8 - case OP_XCLASS: - ccode = code + GET(code, 1); - goto CHECK_CLASS_REPEAT; -#endif - - case OP_CLASS: - case OP_NCLASS: - ccode = code + 33; - -#ifdef SUPPORT_UTF8 - CHECK_CLASS_REPEAT: -#endif - - switch (*ccode) - { - case OP_CRSTAR: /* These could be empty; continue */ - case OP_CRMINSTAR: - case OP_CRQUERY: - case OP_CRMINQUERY: - break; - - default: /* Non-repeat => class must match */ - case OP_CRPLUS: /* These repeats aren't empty */ - case OP_CRMINPLUS: - return FALSE; - - case OP_CRRANGE: - case OP_CRMINRANGE: - if (GET2(ccode, 1) > 0) return FALSE; /* Minimum > 0 */ - break; - } - break; - - /* Opcodes that must match a character */ - - case OP_PROP: - case OP_NOTPROP: - case OP_EXTUNI: - case OP_NOT_DIGIT: - case OP_DIGIT: - case OP_NOT_WHITESPACE: - case OP_WHITESPACE: - case OP_NOT_WORDCHAR: - case OP_WORDCHAR: - case OP_ANY: - case OP_ANYBYTE: - case OP_CHAR: - case OP_CHARNC: - case OP_NOT: - case OP_PLUS: - case OP_MINPLUS: - case OP_EXACT: - case OP_NOTPLUS: - case OP_NOTMINPLUS: - case OP_NOTEXACT: - case OP_TYPEPLUS: - case OP_TYPEMINPLUS: - case OP_TYPEEXACT: - return FALSE; - - /* End of branch */ - - case OP_KET: - case OP_KETRMAX: - case OP_KETRMIN: - case OP_ALT: - return TRUE; - - /* In UTF-8 mode, STAR, MINSTAR, QUERY, MINQUERY, UPTO, and MINUPTO may be - followed by a multibyte character */ - -#ifdef SUPPORT_UTF8 - case OP_STAR: - case OP_MINSTAR: - case OP_QUERY: - case OP_MINQUERY: - case OP_UPTO: - case OP_MINUPTO: - if (utf8) while ((code[2] & 0xc0) == 0x80) code++; - break; -#endif - } - } - -return TRUE; -} - - - -/************************************************* -* Scan compiled regex for non-emptiness * -*************************************************/ - -/* This function is called to check for left recursive calls. We want to check -the current branch of the current pattern to see if it could match the empty -string. If it could, we must look outwards for branches at other levels, -stopping when we pass beyond the bracket which is the subject of the recursion. - -Arguments: - code points to start of the recursion - endcode points to where to stop (current RECURSE item) - bcptr points to the chain of current (unclosed) branch starts - utf8 TRUE if in UTF-8 mode - -Returns: TRUE if what is matched could be empty -*/ - -static BOOL -could_be_empty(const uschar *code, const uschar *endcode, branch_chain *bcptr, - BOOL utf8) -{ -while (bcptr != NULL && bcptr->current >= code) - { - if (!could_be_empty_branch(bcptr->current, endcode, utf8)) return FALSE; - bcptr = bcptr->outer; - } -return TRUE; -} - - - -/************************************************* -* Check for POSIX class syntax * -*************************************************/ - -/* This function is called when the sequence "[:" or "[." or "[=" is -encountered in a character class. It checks whether this is followed by an -optional ^ and then a sequence of letters, terminated by a matching ":]" or -".]" or "=]". - -Argument: - ptr pointer to the initial [ - endptr where to return the end pointer - cd pointer to compile data - -Returns: TRUE or FALSE -*/ - -static BOOL -check_posix_syntax(const uschar *ptr, const uschar **endptr, compile_data *cd) -{ -int terminator; /* Don't combine these lines; the Solaris cc */ -terminator = *(++ptr); /* compiler warns about "non-constant" initializer. */ -if (*(++ptr) == '^') ptr++; -while ((cd->ctypes[*ptr] & ctype_letter) != 0) ptr++; -if (*ptr == terminator && ptr[1] == ']') - { - *endptr = ptr; - return TRUE; - } -return FALSE; -} - - - - -/************************************************* -* Check POSIX class name * -*************************************************/ - -/* This function is called to check the name given in a POSIX-style class entry -such as [:alnum:]. - -Arguments: - ptr points to the first letter - len the length of the name - -Returns: a value representing the name, or -1 if unknown -*/ - -static int -check_posix_name(const uschar *ptr, int len) -{ -register int yield = 0; -while (posix_name_lengths[yield] != 0) - { - if (len == posix_name_lengths[yield] && - strncmp((const char *)ptr, posix_names[yield], len) == 0) return yield; - yield++; - } -return -1; -} - - -/************************************************* -* Adjust OP_RECURSE items in repeated group * -*************************************************/ - -/* OP_RECURSE items contain an offset from the start of the regex to the group -that is referenced. This means that groups can be replicated for fixed -repetition simply by copying (because the recursion is allowed to refer to -earlier groups that are outside the current group). However, when a group is -optional (i.e. the minimum quantifier is zero), OP_BRAZERO is inserted before -it, after it has been compiled. This means that any OP_RECURSE items within it -that refer to the group itself or any contained groups have to have their -offsets adjusted. That is the job of this function. Before it is called, the -partially compiled regex must be temporarily terminated with OP_END. - -Arguments: - group points to the start of the group - adjust the amount by which the group is to be moved - utf8 TRUE in UTF-8 mode - cd contains pointers to tables etc. - -Returns: nothing -*/ - -static void -adjust_recurse(uschar *group, int adjust, BOOL utf8, compile_data *cd) -{ -uschar *ptr = group; -while ((ptr = (uschar *)find_recurse(ptr, utf8)) != NULL) - { - int offset = GET(ptr, 1); - if (cd->start_code + offset >= group) PUT(ptr, 1, offset + adjust); - ptr += 1 + LINK_SIZE; - } -} - - - -/************************************************* -* Insert an automatic callout point * -*************************************************/ - -/* This function is called when the PCRE_AUTO_CALLOUT option is set, to insert -callout points before each pattern item. - -Arguments: - code current code pointer - ptr current pattern pointer - cd pointers to tables etc - -Returns: new code pointer -*/ - -static uschar * -auto_callout(uschar *code, const uschar *ptr, compile_data *cd) -{ -*code++ = OP_CALLOUT; -*code++ = 255; -PUT(code, 0, ptr - cd->start_pattern); /* Pattern offset */ -PUT(code, LINK_SIZE, 0); /* Default length */ -return code + 2*LINK_SIZE; -} - - - -/************************************************* -* Complete a callout item * -*************************************************/ - -/* A callout item contains the length of the next item in the pattern, which -we can't fill in till after we have reached the relevant point. This is used -for both automatic and manual callouts. - -Arguments: - previous_callout points to previous callout item - ptr current pattern pointer - cd pointers to tables etc - -Returns: nothing -*/ - -static void -complete_callout(uschar *previous_callout, const uschar *ptr, compile_data *cd) -{ -int length = ptr - cd->start_pattern - GET(previous_callout, 2); -PUT(previous_callout, 2 + LINK_SIZE, length); -} - - - -#ifdef SUPPORT_UCP -/************************************************* -* Get othercase range * -*************************************************/ - -/* This function is passed the start and end of a class range, in UTF-8 mode -with UCP support. It searches up the characters, looking for internal ranges of -characters in the "other" case. Each call returns the next one, updating the -start address. - -Arguments: - cptr points to starting character value; updated - d end value - ocptr where to put start of othercase range - odptr where to put end of othercase range - -Yield: TRUE when range returned; FALSE when no more -*/ - -static BOOL -get_othercase_range(int *cptr, int d, int *ocptr, int *odptr) -{ -int c, chartype, othercase, next; - -for (c = *cptr; c <= d; c++) - { - if (ucp_findchar(c, &chartype, &othercase) == ucp_L && othercase != 0) break; - } - -if (c > d) return FALSE; - -*ocptr = othercase; -next = othercase + 1; - -for (++c; c <= d; c++) - { - if (ucp_findchar(c, &chartype, &othercase) != ucp_L || othercase != next) - break; - next++; - } - -*odptr = next - 1; -*cptr = c; - -return TRUE; -} -#endif /* SUPPORT_UCP */ - - -/************************************************* -* Compile one branch * -*************************************************/ - -/* Scan the pattern, compiling it into the code vector. If the options are -changed during the branch, the pointer is used to change the external options -bits. - -Arguments: - optionsptr pointer to the option bits - brackets points to number of extracting brackets used - codeptr points to the pointer to the current code point - ptrptr points to the current pattern pointer - errorptr points to pointer to error message - firstbyteptr set to initial literal character, or < 0 (REQ_UNSET, REQ_NONE) - reqbyteptr set to the last literal character required, else < 0 - bcptr points to current branch chain - cd contains pointers to tables etc. - -Returns: TRUE on success - FALSE, with *errorptr set on error -*/ - -static BOOL -compile_branch(int *optionsptr, int *brackets, uschar **codeptr, - const uschar **ptrptr, const char **errorptr, int *firstbyteptr, - int *reqbyteptr, branch_chain *bcptr, compile_data *cd) -{ -int repeat_type, op_type; -int repeat_min = 0, repeat_max = 0; /* To please picky compilers */ -int bravalue = 0; -int greedy_default, greedy_non_default; -int firstbyte, reqbyte; -int zeroreqbyte, zerofirstbyte; -int req_caseopt, reqvary, tempreqvary; -int condcount = 0; -int options = *optionsptr; -int after_manual_callout = 0; -register int c; -register uschar *code = *codeptr; -uschar *tempcode; -BOOL inescq = FALSE; -BOOL groupsetfirstbyte = FALSE; -const uschar *ptr = *ptrptr; -const uschar *tempptr; -uschar *previous = NULL; -uschar *previous_callout = NULL; -uschar classbits[32]; - -#ifdef SUPPORT_UTF8 -BOOL class_utf8; -BOOL utf8 = (options & PCRE_UTF8) != 0; -uschar *class_utf8data; -uschar utf8_char[6]; -#else -BOOL utf8 = FALSE; -#endif - -/* Set up the default and non-default settings for greediness */ - -greedy_default = ((options & PCRE_UNGREEDY) != 0); -greedy_non_default = greedy_default ^ 1; - -/* Initialize no first byte, no required byte. REQ_UNSET means "no char -matching encountered yet". It gets changed to REQ_NONE if we hit something that -matches a non-fixed char first char; reqbyte just remains unset if we never -find one. - -When we hit a repeat whose minimum is zero, we may have to adjust these values -to take the zero repeat into account. This is implemented by setting them to -zerofirstbyte and zeroreqbyte when such a repeat is encountered. The individual -item types that can be repeated set these backoff variables appropriately. */ - -firstbyte = reqbyte = zerofirstbyte = zeroreqbyte = REQ_UNSET; - -/* The variable req_caseopt contains either the REQ_CASELESS value or zero, -according to the current setting of the caseless flag. REQ_CASELESS is a bit -value > 255. It is added into the firstbyte or reqbyte variables to record the -case status of the value. This is used only for ASCII characters. */ - -req_caseopt = ((options & PCRE_CASELESS) != 0)? REQ_CASELESS : 0; - -/* Switch on next character until the end of the branch */ - -for (;; ptr++) - { - BOOL negate_class; - BOOL possessive_quantifier; - BOOL is_quantifier; - int class_charcount; - int class_lastchar; - int newoptions; - int recno; - int skipbytes; - int subreqbyte; - int subfirstbyte; - int mclength; - uschar mcbuffer[8]; - - /* Next byte in the pattern */ - - c = *ptr; - - /* If in \Q...\E, check for the end; if not, we have a literal */ - - if (inescq && c != 0) - { - if (c == '\\' && ptr[1] == 'E') - { - inescq = FALSE; - ptr++; - continue; - } - else - { - if (previous_callout != NULL) - { - complete_callout(previous_callout, ptr, cd); - previous_callout = NULL; - } - if ((options & PCRE_AUTO_CALLOUT) != 0) - { - previous_callout = code; - code = auto_callout(code, ptr, cd); - } - goto NORMAL_CHAR; - } - } - - /* Fill in length of a previous callout, except when the next thing is - a quantifier. */ - - is_quantifier = c == '*' || c == '+' || c == '?' || - (c == '{' && is_counted_repeat(ptr+1)); - - if (!is_quantifier && previous_callout != NULL && - after_manual_callout-- <= 0) - { - complete_callout(previous_callout, ptr, cd); - previous_callout = NULL; - } - - /* In extended mode, skip white space and comments */ - - if ((options & PCRE_EXTENDED) != 0) - { - if ((cd->ctypes[c] & ctype_space) != 0) continue; - if (c == '#') - { - /* The space before the ; is to avoid a warning on a silly compiler - on the Macintosh. */ - while ((c = *(++ptr)) != 0 && c != NEWLINE) ; - if (c != 0) continue; /* Else fall through to handle end of string */ - } - } - - /* No auto callout for quantifiers. */ - - if ((options & PCRE_AUTO_CALLOUT) != 0 && !is_quantifier) - { - previous_callout = code; - code = auto_callout(code, ptr, cd); - } - - switch(c) - { - /* The branch terminates at end of string, |, or ). */ - - case 0: - case '|': - case ')': - *firstbyteptr = firstbyte; - *reqbyteptr = reqbyte; - *codeptr = code; - *ptrptr = ptr; - return TRUE; - - /* Handle single-character metacharacters. In multiline mode, ^ disables - the setting of any following char as a first character. */ - - case '^': - if ((options & PCRE_MULTILINE) != 0) - { - if (firstbyte == REQ_UNSET) firstbyte = REQ_NONE; - } - previous = NULL; - *code++ = OP_CIRC; - break; - - case '$': - previous = NULL; - *code++ = OP_DOLL; - break; - - /* There can never be a first char if '.' is first, whatever happens about - repeats. The value of reqbyte doesn't change either. */ - - case '.': - if (firstbyte == REQ_UNSET) firstbyte = REQ_NONE; - zerofirstbyte = firstbyte; - zeroreqbyte = reqbyte; - previous = code; - *code++ = OP_ANY; - break; - - /* Character classes. If the included characters are all < 255 in value, we - build a 32-byte bitmap of the permitted characters, except in the special - case where there is only one such character. For negated classes, we build - the map as usual, then invert it at the end. However, we use a different - opcode so that data characters > 255 can be handled correctly. - - If the class contains characters outside the 0-255 range, a different - opcode is compiled. It may optionally have a bit map for characters < 256, - but those above are are explicitly listed afterwards. A flag byte tells - whether the bitmap is present, and whether this is a negated class or not. - */ - - case '[': - previous = code; - - /* PCRE supports POSIX class stuff inside a class. Perl gives an error if - they are encountered at the top level, so we'll do that too. */ - - if ((ptr[1] == ':' || ptr[1] == '.' || ptr[1] == '=') && - check_posix_syntax(ptr, &tempptr, cd)) - { - *errorptr = (ptr[1] == ':')? ERR13 : ERR31; - goto FAILED; - } - - /* If the first character is '^', set the negation flag and skip it. */ - - if ((c = *(++ptr)) == '^') - { - negate_class = TRUE; - c = *(++ptr); - } - else - { - negate_class = FALSE; - } - - /* Keep a count of chars with values < 256 so that we can optimize the case - of just a single character (as long as it's < 256). For higher valued UTF-8 - characters, we don't yet do any optimization. */ - - class_charcount = 0; - class_lastchar = -1; - -#ifdef SUPPORT_UTF8 - class_utf8 = FALSE; /* No chars >= 256 */ - class_utf8data = code + LINK_SIZE + 34; /* For UTF-8 items */ -#endif - - /* Initialize the 32-char bit map to all zeros. We have to build the - map in a temporary bit of store, in case the class contains only 1 - character (< 256), because in that case the compiled code doesn't use the - bit map. */ - - memset(classbits, 0, 32 * sizeof(uschar)); - - /* Process characters until ] is reached. By writing this as a "do" it - means that an initial ] is taken as a data character. The first pass - through the regex checked the overall syntax, so we don't need to be very - strict here. At the start of the loop, c contains the first byte of the - character. */ - - do - { -#ifdef SUPPORT_UTF8 - if (utf8 && c > 127) - { /* Braces are required because the */ - GETCHARLEN(c, ptr, ptr); /* macro generates multiple statements */ - } -#endif - - /* Inside \Q...\E everything is literal except \E */ - - if (inescq) - { - if (c == '\\' && ptr[1] == 'E') - { - inescq = FALSE; - ptr++; - continue; - } - else goto LONE_SINGLE_CHARACTER; - } - - /* Handle POSIX class names. Perl allows a negation extension of the - form [:^name:]. A square bracket that doesn't match the syntax is - treated as a literal. We also recognize the POSIX constructions - [.ch.] and [=ch=] ("collating elements") and fault them, as Perl - 5.6 and 5.8 do. */ - - if (c == '[' && - (ptr[1] == ':' || ptr[1] == '.' || ptr[1] == '=') && - check_posix_syntax(ptr, &tempptr, cd)) - { - BOOL local_negate = FALSE; - int posix_class, i; - register const uschar *cbits = cd->cbits; - - if (ptr[1] != ':') - { - *errorptr = ERR31; - goto FAILED; - } - - ptr += 2; - if (*ptr == '^') - { - local_negate = TRUE; - ptr++; - } - - posix_class = check_posix_name(ptr, tempptr - ptr); - if (posix_class < 0) - { - *errorptr = ERR30; - goto FAILED; - } - - /* If matching is caseless, upper and lower are converted to - alpha. This relies on the fact that the class table starts with - alpha, lower, upper as the first 3 entries. */ - - if ((options & PCRE_CASELESS) != 0 && posix_class <= 2) - posix_class = 0; - - /* Or into the map we are building up to 3 of the static class - tables, or their negations. The [:blank:] class sets up the same - chars as the [:space:] class (all white space). We remove the vertical - white space chars afterwards. */ - - posix_class *= 3; - for (i = 0; i < 3; i++) - { - BOOL blankclass = strncmp((char *)ptr, "blank", 5) == 0; - int taboffset = posix_class_maps[posix_class + i]; - if (taboffset < 0) break; - if (local_negate) - { - if (i == 0) - for (c = 0; c < 32; c++) classbits[c] |= ~cbits[c+taboffset]; - else - for (c = 0; c < 32; c++) classbits[c] &= ~cbits[c+taboffset]; - if (blankclass) classbits[1] |= 0x3c; - } - else - { - for (c = 0; c < 32; c++) classbits[c] |= cbits[c+taboffset]; - if (blankclass) classbits[1] &= ~0x3c; - } - } - - ptr = tempptr + 1; - class_charcount = 10; /* Set > 1; assumes more than 1 per class */ - continue; /* End of POSIX syntax handling */ - } - - /* Backslash may introduce a single character, or it may introduce one - of the specials, which just set a flag. Escaped items are checked for - validity in the pre-compiling pass. The sequence \b is a special case. - Inside a class (and only there) it is treated as backspace. Elsewhere - it marks a word boundary. Other escapes have preset maps ready to - or into the one we are building. We assume they have more than one - character in them, so set class_charcount bigger than one. */ - - if (c == '\\') - { - c = check_escape(&ptr, errorptr, *brackets, options, TRUE); - - if (-c == ESC_b) c = '\b'; /* \b is backslash in a class */ - else if (-c == ESC_X) c = 'X'; /* \X is literal X in a class */ - else if (-c == ESC_Q) /* Handle start of quoted string */ - { - if (ptr[1] == '\\' && ptr[2] == 'E') - { - ptr += 2; /* avoid empty string */ - } - else inescq = TRUE; - continue; - } - - if (c < 0) - { - register const uschar *cbits = cd->cbits; - class_charcount += 2; /* Greater than 1 is what matters */ - switch (-c) - { - case ESC_d: - for (c = 0; c < 32; c++) classbits[c] |= cbits[c+cbit_digit]; - continue; - - case ESC_D: - for (c = 0; c < 32; c++) classbits[c] |= ~cbits[c+cbit_digit]; - continue; - - case ESC_w: - for (c = 0; c < 32; c++) classbits[c] |= cbits[c+cbit_word]; - continue; - - case ESC_W: - for (c = 0; c < 32; c++) classbits[c] |= ~cbits[c+cbit_word]; - continue; - - case ESC_s: - for (c = 0; c < 32; c++) classbits[c] |= cbits[c+cbit_space]; - classbits[1] &= ~0x08; /* Perl 5.004 onwards omits VT from \s */ - continue; - - case ESC_S: - for (c = 0; c < 32; c++) classbits[c] |= ~cbits[c+cbit_space]; - classbits[1] |= 0x08; /* Perl 5.004 onwards omits VT from \s */ - continue; - -#ifdef SUPPORT_UCP - case ESC_p: - case ESC_P: - { - BOOL negated; - int property = get_ucp(&ptr, &negated, errorptr); - if (property < 0) goto FAILED; - class_utf8 = TRUE; - *class_utf8data++ = ((-c == ESC_p) != negated)? - XCL_PROP : XCL_NOTPROP; - *class_utf8data++ = property; - class_charcount -= 2; /* Not a < 256 character */ - } - continue; -#endif - - /* Unrecognized escapes are faulted if PCRE is running in its - strict mode. By default, for compatibility with Perl, they are - treated as literals. */ - - default: - if ((options & PCRE_EXTRA) != 0) - { - *errorptr = ERR7; - goto FAILED; - } - c = *ptr; /* The final character */ - class_charcount -= 2; /* Undo the default count from above */ - } - } - - /* Fall through if we have a single character (c >= 0). This may be - > 256 in UTF-8 mode. */ - - } /* End of backslash handling */ - - /* A single character may be followed by '-' to form a range. However, - Perl does not permit ']' to be the end of the range. A '-' character - here is treated as a literal. */ - - if (ptr[1] == '-' && ptr[2] != ']') - { - int d; - ptr += 2; - -#ifdef SUPPORT_UTF8 - if (utf8) - { /* Braces are required because the */ - GETCHARLEN(d, ptr, ptr); /* macro generates multiple statements */ - } - else -#endif - d = *ptr; /* Not UTF-8 mode */ - - /* The second part of a range can be a single-character escape, but - not any of the other escapes. Perl 5.6 treats a hyphen as a literal - in such circumstances. */ - - if (d == '\\') - { - const uschar *oldptr = ptr; - d = check_escape(&ptr, errorptr, *brackets, options, TRUE); - - /* \b is backslash; \X is literal X; any other special means the '-' - was literal */ - - if (d < 0) - { - if (d == -ESC_b) d = '\b'; - else if (d == -ESC_X) d = 'X'; else - { - ptr = oldptr - 2; - goto LONE_SINGLE_CHARACTER; /* A few lines below */ - } - } - } - - /* The check that the two values are in the correct order happens in - the pre-pass. Optimize one-character ranges */ - - if (d == c) goto LONE_SINGLE_CHARACTER; /* A few lines below */ - - /* In UTF-8 mode, if the upper limit is > 255, or > 127 for caseless - matching, we have to use an XCLASS with extra data items. Caseless - matching for characters > 127 is available only if UCP support is - available. */ - -#ifdef SUPPORT_UTF8 - if (utf8 && (d > 255 || ((options & PCRE_CASELESS) != 0 && d > 127))) - { - class_utf8 = TRUE; - - /* With UCP support, we can find the other case equivalents of - the relevant characters. There may be several ranges. Optimize how - they fit with the basic range. */ - -#ifdef SUPPORT_UCP - if ((options & PCRE_CASELESS) != 0) - { - int occ, ocd; - int cc = c; - int origd = d; - while (get_othercase_range(&cc, origd, &occ, &ocd)) - { - if (occ >= c && ocd <= d) continue; /* Skip embedded ranges */ - - if (occ < c && ocd >= c - 1) /* Extend the basic range */ - { /* if there is overlap, */ - c = occ; /* noting that if occ < c */ - continue; /* we can't have ocd > d */ - } /* because a subrange is */ - if (ocd > d && occ <= d + 1) /* always shorter than */ - { /* the basic range. */ - d = ocd; - continue; - } - - if (occ == ocd) - { - *class_utf8data++ = XCL_SINGLE; - } - else - { - *class_utf8data++ = XCL_RANGE; - class_utf8data += ord2utf8(occ, class_utf8data); - } - class_utf8data += ord2utf8(ocd, class_utf8data); - } - } -#endif /* SUPPORT_UCP */ - - /* Now record the original range, possibly modified for UCP caseless - overlapping ranges. */ - - *class_utf8data++ = XCL_RANGE; - class_utf8data += ord2utf8(c, class_utf8data); - class_utf8data += ord2utf8(d, class_utf8data); - - /* With UCP support, we are done. Without UCP support, there is no - caseless matching for UTF-8 characters > 127; we can use the bit map - for the smaller ones. */ - -#ifdef SUPPORT_UCP - continue; /* With next character in the class */ -#else - if ((options & PCRE_CASELESS) == 0 || c > 127) continue; - - /* Adjust upper limit and fall through to set up the map */ - - d = 127; - -#endif /* SUPPORT_UCP */ - } -#endif /* SUPPORT_UTF8 */ - - /* We use the bit map for all cases when not in UTF-8 mode; else - ranges that lie entirely within 0-127 when there is UCP support; else - for partial ranges without UCP support. */ - - for (; c <= d; c++) - { - classbits[c/8] |= (1 << (c&7)); - if ((options & PCRE_CASELESS) != 0) - { - int uc = cd->fcc[c]; /* flip case */ - classbits[uc/8] |= (1 << (uc&7)); - } - class_charcount++; /* in case a one-char range */ - class_lastchar = c; - } - - continue; /* Go get the next char in the class */ - } - - /* Handle a lone single character - we can get here for a normal - non-escape char, or after \ that introduces a single character or for an - apparent range that isn't. */ - - LONE_SINGLE_CHARACTER: - - /* Handle a character that cannot go in the bit map */ - -#ifdef SUPPORT_UTF8 - if (utf8 && (c > 255 || ((options & PCRE_CASELESS) != 0 && c > 127))) - { - class_utf8 = TRUE; - *class_utf8data++ = XCL_SINGLE; - class_utf8data += ord2utf8(c, class_utf8data); - -#ifdef SUPPORT_UCP - if ((options & PCRE_CASELESS) != 0) - { - int chartype; - int othercase; - if (ucp_findchar(c, &chartype, &othercase) >= 0 && othercase > 0) - { - *class_utf8data++ = XCL_SINGLE; - class_utf8data += ord2utf8(othercase, class_utf8data); - } - } -#endif /* SUPPORT_UCP */ - - } - else -#endif /* SUPPORT_UTF8 */ - - /* Handle a single-byte character */ - { - classbits[c/8] |= (1 << (c&7)); - if ((options & PCRE_CASELESS) != 0) - { - c = cd->fcc[c]; /* flip case */ - classbits[c/8] |= (1 << (c&7)); - } - class_charcount++; - class_lastchar = c; - } - } - - /* Loop until ']' reached; the check for end of string happens inside the - loop. This "while" is the end of the "do" above. */ - - while ((c = *(++ptr)) != ']' || inescq); - - /* If class_charcount is 1, we saw precisely one character whose value is - less than 256. In non-UTF-8 mode we can always optimize. In UTF-8 mode, we - can optimize the negative case only if there were no characters >= 128 - because OP_NOT and the related opcodes like OP_NOTSTAR operate on - single-bytes only. This is an historical hangover. Maybe one day we can - tidy these opcodes to handle multi-byte characters. - - The optimization throws away the bit map. We turn the item into a - 1-character OP_CHAR[NC] if it's positive, or OP_NOT if it's negative. Note - that OP_NOT does not support multibyte characters. In the positive case, it - can cause firstbyte to be set. Otherwise, there can be no first char if - this item is first, whatever repeat count may follow. In the case of - reqbyte, save the previous value for reinstating. */ - -#ifdef SUPPORT_UTF8 - if (class_charcount == 1 && - (!utf8 || - (!class_utf8 && (!negate_class || class_lastchar < 128)))) - -#else - if (class_charcount == 1) -#endif - { - zeroreqbyte = reqbyte; - - /* The OP_NOT opcode works on one-byte characters only. */ - - if (negate_class) - { - if (firstbyte == REQ_UNSET) firstbyte = REQ_NONE; - zerofirstbyte = firstbyte; - *code++ = OP_NOT; - *code++ = class_lastchar; - break; - } - - /* For a single, positive character, get the value into mcbuffer, and - then we can handle this with the normal one-character code. */ - -#ifdef SUPPORT_UTF8 - if (utf8 && class_lastchar > 127) - mclength = ord2utf8(class_lastchar, mcbuffer); - else -#endif - { - mcbuffer[0] = class_lastchar; - mclength = 1; - } - goto ONE_CHAR; - } /* End of 1-char optimization */ - - /* The general case - not the one-char optimization. If this is the first - thing in the branch, there can be no first char setting, whatever the - repeat count. Any reqbyte setting must remain unchanged after any kind of - repeat. */ - - if (firstbyte == REQ_UNSET) firstbyte = REQ_NONE; - zerofirstbyte = firstbyte; - zeroreqbyte = reqbyte; - - /* If there are characters with values > 255, we have to compile an - extended class, with its own opcode. If there are no characters < 256, - we can omit the bitmap. */ - -#ifdef SUPPORT_UTF8 - if (class_utf8) - { - *class_utf8data++ = XCL_END; /* Marks the end of extra data */ - *code++ = OP_XCLASS; - code += LINK_SIZE; - *code = negate_class? XCL_NOT : 0; - - /* If the map is required, install it, and move on to the end of - the extra data */ - - if (class_charcount > 0) - { - *code++ |= XCL_MAP; - memcpy(code, classbits, 32); - code = class_utf8data; - } - - /* If the map is not required, slide down the extra data. */ - - else - { - int len = class_utf8data - (code + 33); - memmove(code + 1, code + 33, len); - code += len + 1; - } - - /* Now fill in the complete length of the item */ - - PUT(previous, 1, code - previous); - break; /* End of class handling */ - } -#endif - - /* If there are no characters > 255, negate the 32-byte map if necessary, - and copy it into the code vector. If this is the first thing in the branch, - there can be no first char setting, whatever the repeat count. Any reqbyte - setting must remain unchanged after any kind of repeat. */ - - if (negate_class) - { - *code++ = OP_NCLASS; - for (c = 0; c < 32; c++) code[c] = ~classbits[c]; - } - else - { - *code++ = OP_CLASS; - memcpy(code, classbits, 32); - } - code += 32; - break; - - /* Various kinds of repeat; '{' is not necessarily a quantifier, but this - has been tested above. */ - - case '{': - if (!is_quantifier) goto NORMAL_CHAR; - ptr = read_repeat_counts(ptr+1, &repeat_min, &repeat_max, errorptr); - if (*errorptr != NULL) goto FAILED; - goto REPEAT; - - case '*': - repeat_min = 0; - repeat_max = -1; - goto REPEAT; - - case '+': - repeat_min = 1; - repeat_max = -1; - goto REPEAT; - - case '?': - repeat_min = 0; - repeat_max = 1; - - REPEAT: - if (previous == NULL) - { - *errorptr = ERR9; - goto FAILED; - } - - if (repeat_min == 0) - { - firstbyte = zerofirstbyte; /* Adjust for zero repeat */ - reqbyte = zeroreqbyte; /* Ditto */ - } - - /* Remember whether this is a variable length repeat */ - - reqvary = (repeat_min == repeat_max)? 0 : REQ_VARY; - - op_type = 0; /* Default single-char op codes */ - possessive_quantifier = FALSE; /* Default not possessive quantifier */ - - /* Save start of previous item, in case we have to move it up to make space - for an inserted OP_ONCE for the additional '+' extension. */ - - tempcode = previous; - - /* If the next character is '+', we have a possessive quantifier. This - implies greediness, whatever the setting of the PCRE_UNGREEDY option. - If the next character is '?' this is a minimizing repeat, by default, - but if PCRE_UNGREEDY is set, it works the other way round. We change the - repeat type to the non-default. */ - - if (ptr[1] == '+') - { - repeat_type = 0; /* Force greedy */ - possessive_quantifier = TRUE; - ptr++; - } - else if (ptr[1] == '?') - { - repeat_type = greedy_non_default; - ptr++; - } - else repeat_type = greedy_default; - - /* If previous was a recursion, we need to wrap it inside brackets so that - it can be replicated if necessary. */ - - if (*previous == OP_RECURSE) - { - memmove(previous + 1 + LINK_SIZE, previous, 1 + LINK_SIZE); - code += 1 + LINK_SIZE; - *previous = OP_BRA; - PUT(previous, 1, code - previous); - *code = OP_KET; - PUT(code, 1, code - previous); - code += 1 + LINK_SIZE; - } - - /* If previous was a character match, abolish the item and generate a - repeat item instead. If a char item has a minumum of more than one, ensure - that it is set in reqbyte - it might not be if a sequence such as x{3} is - the first thing in a branch because the x will have gone into firstbyte - instead. */ - - if (*previous == OP_CHAR || *previous == OP_CHARNC) - { - /* Deal with UTF-8 characters that take up more than one byte. It's - easier to write this out separately than try to macrify it. Use c to - hold the length of the character in bytes, plus 0x80 to flag that it's a - length rather than a small character. */ - -#ifdef SUPPORT_UTF8 - if (utf8 && (code[-1] & 0x80) != 0) - { - uschar *lastchar = code - 1; - while((*lastchar & 0xc0) == 0x80) lastchar--; - c = code - lastchar; /* Length of UTF-8 character */ - memcpy(utf8_char, lastchar, c); /* Save the char */ - c |= 0x80; /* Flag c as a length */ - } - else -#endif - - /* Handle the case of a single byte - either with no UTF8 support, or - with UTF-8 disabled, or for a UTF-8 character < 128. */ - - { - c = code[-1]; - if (repeat_min > 1) reqbyte = c | req_caseopt | cd->req_varyopt; - } - - goto OUTPUT_SINGLE_REPEAT; /* Code shared with single character types */ - } - - /* If previous was a single negated character ([^a] or similar), we use - one of the special opcodes, replacing it. The code is shared with single- - character repeats by setting opt_type to add a suitable offset into - repeat_type. OP_NOT is currently used only for single-byte chars. */ - - else if (*previous == OP_NOT) - { - op_type = OP_NOTSTAR - OP_STAR; /* Use "not" opcodes */ - c = previous[1]; - goto OUTPUT_SINGLE_REPEAT; - } - - /* If previous was a character type match (\d or similar), abolish it and - create a suitable repeat item. The code is shared with single-character - repeats by setting op_type to add a suitable offset into repeat_type. Note - the the Unicode property types will be present only when SUPPORT_UCP is - defined, but we don't wrap the little bits of code here because it just - makes it horribly messy. */ - - else if (*previous < OP_EODN) - { - uschar *oldcode; - int prop_type; - op_type = OP_TYPESTAR - OP_STAR; /* Use type opcodes */ - c = *previous; - - OUTPUT_SINGLE_REPEAT: - prop_type = (*previous == OP_PROP || *previous == OP_NOTPROP)? - previous[1] : -1; - - oldcode = code; - code = previous; /* Usually overwrite previous item */ - - /* If the maximum is zero then the minimum must also be zero; Perl allows - this case, so we do too - by simply omitting the item altogether. */ - - if (repeat_max == 0) goto END_REPEAT; - - /* All real repeats make it impossible to handle partial matching (maybe - one day we will be able to remove this restriction). */ - - if (repeat_max != 1) cd->nopartial = TRUE; - - /* Combine the op_type with the repeat_type */ - - repeat_type += op_type; - - /* A minimum of zero is handled either as the special case * or ?, or as - an UPTO, with the maximum given. */ - - if (repeat_min == 0) - { - if (repeat_max == -1) *code++ = OP_STAR + repeat_type; - else if (repeat_max == 1) *code++ = OP_QUERY + repeat_type; - else - { - *code++ = OP_UPTO + repeat_type; - PUT2INC(code, 0, repeat_max); - } - } - - /* A repeat minimum of 1 is optimized into some special cases. If the - maximum is unlimited, we use OP_PLUS. Otherwise, the original item it - left in place and, if the maximum is greater than 1, we use OP_UPTO with - one less than the maximum. */ - - else if (repeat_min == 1) - { - if (repeat_max == -1) - *code++ = OP_PLUS + repeat_type; - else - { - code = oldcode; /* leave previous item in place */ - if (repeat_max == 1) goto END_REPEAT; - *code++ = OP_UPTO + repeat_type; - PUT2INC(code, 0, repeat_max - 1); - } - } - - /* The case {n,n} is just an EXACT, while the general case {n,m} is - handled as an EXACT followed by an UPTO. */ - - else - { - *code++ = OP_EXACT + op_type; /* NB EXACT doesn't have repeat_type */ - PUT2INC(code, 0, repeat_min); - - /* If the maximum is unlimited, insert an OP_STAR. Before doing so, - we have to insert the character for the previous code. For a repeated - Unicode property match, there is an extra byte that defines the - required property. In UTF-8 mode, long characters have their length in - c, with the 0x80 bit as a flag. */ - - if (repeat_max < 0) - { -#ifdef SUPPORT_UTF8 - if (utf8 && c >= 128) - { - memcpy(code, utf8_char, c & 7); - code += c & 7; - } - else -#endif - { - *code++ = c; - if (prop_type >= 0) *code++ = prop_type; - } - *code++ = OP_STAR + repeat_type; - } - - /* Else insert an UPTO if the max is greater than the min, again - preceded by the character, for the previously inserted code. */ - - else if (repeat_max != repeat_min) - { -#ifdef SUPPORT_UTF8 - if (utf8 && c >= 128) - { - memcpy(code, utf8_char, c & 7); - code += c & 7; - } - else -#endif - *code++ = c; - if (prop_type >= 0) *code++ = prop_type; - repeat_max -= repeat_min; - *code++ = OP_UPTO + repeat_type; - PUT2INC(code, 0, repeat_max); - } - } - - /* The character or character type itself comes last in all cases. */ - -#ifdef SUPPORT_UTF8 - if (utf8 && c >= 128) - { - memcpy(code, utf8_char, c & 7); - code += c & 7; - } - else -#endif - *code++ = c; - - /* For a repeated Unicode property match, there is an extra byte that - defines the required property. */ - -#ifdef SUPPORT_UCP - if (prop_type >= 0) *code++ = prop_type; -#endif - } - - /* If previous was a character class or a back reference, we put the repeat - stuff after it, but just skip the item if the repeat was {0,0}. */ - - else if (*previous == OP_CLASS || - *previous == OP_NCLASS || -#ifdef SUPPORT_UTF8 - *previous == OP_XCLASS || -#endif - *previous == OP_REF) - { - if (repeat_max == 0) - { - code = previous; - goto END_REPEAT; - } - - /* All real repeats make it impossible to handle partial matching (maybe - one day we will be able to remove this restriction). */ - - if (repeat_max != 1) cd->nopartial = TRUE; - - if (repeat_min == 0 && repeat_max == -1) - *code++ = OP_CRSTAR + repeat_type; - else if (repeat_min == 1 && repeat_max == -1) - *code++ = OP_CRPLUS + repeat_type; - else if (repeat_min == 0 && repeat_max == 1) - *code++ = OP_CRQUERY + repeat_type; - else - { - *code++ = OP_CRRANGE + repeat_type; - PUT2INC(code, 0, repeat_min); - if (repeat_max == -1) repeat_max = 0; /* 2-byte encoding for max */ - PUT2INC(code, 0, repeat_max); - } - } - - /* If previous was a bracket group, we may have to replicate it in certain - cases. */ - - else if (*previous >= OP_BRA || *previous == OP_ONCE || - *previous == OP_COND) - { - register int i; - int ketoffset = 0; - int len = code - previous; - uschar *bralink = NULL; - - /* If the maximum repeat count is unlimited, find the end of the bracket - by scanning through from the start, and compute the offset back to it - from the current code pointer. There may be an OP_OPT setting following - the final KET, so we can't find the end just by going back from the code - pointer. */ - - if (repeat_max == -1) - { - register uschar *ket = previous; - do ket += GET(ket, 1); while (*ket != OP_KET); - ketoffset = code - ket; - } - - /* The case of a zero minimum is special because of the need to stick - OP_BRAZERO in front of it, and because the group appears once in the - data, whereas in other cases it appears the minimum number of times. For - this reason, it is simplest to treat this case separately, as otherwise - the code gets far too messy. There are several special subcases when the - minimum is zero. */ - - if (repeat_min == 0) - { - /* If the maximum is also zero, we just omit the group from the output - altogether. */ - - if (repeat_max == 0) - { - code = previous; - goto END_REPEAT; - } - - /* If the maximum is 1 or unlimited, we just have to stick in the - BRAZERO and do no more at this point. However, we do need to adjust - any OP_RECURSE calls inside the group that refer to the group itself or - any internal group, because the offset is from the start of the whole - regex. Temporarily terminate the pattern while doing this. */ - - if (repeat_max <= 1) - { - *code = OP_END; - adjust_recurse(previous, 1, utf8, cd); - memmove(previous+1, previous, len); - code++; - *previous++ = OP_BRAZERO + repeat_type; - } - - /* If the maximum is greater than 1 and limited, we have to replicate - in a nested fashion, sticking OP_BRAZERO before each set of brackets. - The first one has to be handled carefully because it's the original - copy, which has to be moved up. The remainder can be handled by code - that is common with the non-zero minimum case below. We have to - adjust the value or repeat_max, since one less copy is required. Once - again, we may have to adjust any OP_RECURSE calls inside the group. */ - - else - { - int offset; - *code = OP_END; - adjust_recurse(previous, 2 + LINK_SIZE, utf8, cd); - memmove(previous + 2 + LINK_SIZE, previous, len); - code += 2 + LINK_SIZE; - *previous++ = OP_BRAZERO + repeat_type; - *previous++ = OP_BRA; - - /* We chain together the bracket offset fields that have to be - filled in later when the ends of the brackets are reached. */ - - offset = (bralink == NULL)? 0 : previous - bralink; - bralink = previous; - PUTINC(previous, 0, offset); - } - - repeat_max--; - } - - /* If the minimum is greater than zero, replicate the group as many - times as necessary, and adjust the maximum to the number of subsequent - copies that we need. If we set a first char from the group, and didn't - set a required char, copy the latter from the former. */ - - else - { - if (repeat_min > 1) - { - if (groupsetfirstbyte && reqbyte < 0) reqbyte = firstbyte; - for (i = 1; i < repeat_min; i++) - { - memcpy(code, previous, len); - code += len; - } - } - if (repeat_max > 0) repeat_max -= repeat_min; - } - - /* This code is common to both the zero and non-zero minimum cases. If - the maximum is limited, it replicates the group in a nested fashion, - remembering the bracket starts on a stack. In the case of a zero minimum, - the first one was set up above. In all cases the repeat_max now specifies - the number of additional copies needed. */ - - if (repeat_max >= 0) - { - for (i = repeat_max - 1; i >= 0; i--) - { - *code++ = OP_BRAZERO + repeat_type; - - /* All but the final copy start a new nesting, maintaining the - chain of brackets outstanding. */ - - if (i != 0) - { - int offset; - *code++ = OP_BRA; - offset = (bralink == NULL)? 0 : code - bralink; - bralink = code; - PUTINC(code, 0, offset); - } - - memcpy(code, previous, len); - code += len; - } - - /* Now chain through the pending brackets, and fill in their length - fields (which are holding the chain links pro tem). */ - - while (bralink != NULL) - { - int oldlinkoffset; - int offset = code - bralink + 1; - uschar *bra = code - offset; - oldlinkoffset = GET(bra, 1); - bralink = (oldlinkoffset == 0)? NULL : bralink - oldlinkoffset; - *code++ = OP_KET; - PUTINC(code, 0, offset); - PUT(bra, 1, offset); - } - } - - /* If the maximum is unlimited, set a repeater in the final copy. We - can't just offset backwards from the current code point, because we - don't know if there's been an options resetting after the ket. The - correct offset was computed above. */ - - else code[-ketoffset] = OP_KETRMAX + repeat_type; - } - - /* Else there's some kind of shambles */ - - else - { - *errorptr = ERR11; - goto FAILED; - } - - /* If the character following a repeat is '+', we wrap the entire repeated - item inside OP_ONCE brackets. This is just syntactic sugar, taken from - Sun's Java package. The repeated item starts at tempcode, not at previous, - which might be the first part of a string whose (former) last char we - repeated. However, we don't support '+' after a greediness '?'. */ - - if (possessive_quantifier) - { - int len = code - tempcode; - memmove(tempcode + 1+LINK_SIZE, tempcode, len); - code += 1 + LINK_SIZE; - len += 1 + LINK_SIZE; - tempcode[0] = OP_ONCE; - *code++ = OP_KET; - PUTINC(code, 0, len); - PUT(tempcode, 1, len); - } - - /* In all case we no longer have a previous item. We also set the - "follows varying string" flag for subsequently encountered reqbytes if - it isn't already set and we have just passed a varying length item. */ - - END_REPEAT: - previous = NULL; - cd->req_varyopt |= reqvary; - break; - - - /* Start of nested bracket sub-expression, or comment or lookahead or - lookbehind or option setting or condition. First deal with special things - that can come after a bracket; all are introduced by ?, and the appearance - of any of them means that this is not a referencing group. They were - checked for validity in the first pass over the string, so we don't have to - check for syntax errors here. */ - - case '(': - newoptions = options; - skipbytes = 0; - - if (*(++ptr) == '?') - { - int set, unset; - int *optset; - - switch (*(++ptr)) - { - case '#': /* Comment; skip to ket */ - ptr++; - while (*ptr != ')') ptr++; - continue; - - case ':': /* Non-extracting bracket */ - bravalue = OP_BRA; - ptr++; - break; - - case '(': - bravalue = OP_COND; /* Conditional group */ - - /* Condition to test for recursion */ - - if (ptr[1] == 'R') - { - code[1+LINK_SIZE] = OP_CREF; - PUT2(code, 2+LINK_SIZE, CREF_RECURSE); - skipbytes = 3; - ptr += 3; - } - - /* Condition to test for a numbered subpattern match. We know that - if a digit follows ( then there will just be digits until ) because - the syntax was checked in the first pass. */ - - else if ((digitab[ptr[1]] && ctype_digit) != 0) - { - int condref; /* Don't amalgamate; some compilers */ - condref = *(++ptr) - '0'; /* grumble at autoincrement in declaration */ - while (*(++ptr) != ')') condref = condref*10 + *ptr - '0'; - if (condref == 0) - { - *errorptr = ERR35; - goto FAILED; - } - ptr++; - code[1+LINK_SIZE] = OP_CREF; - PUT2(code, 2+LINK_SIZE, condref); - skipbytes = 3; - } - /* For conditions that are assertions, we just fall through, having - set bravalue above. */ - break; - - case '=': /* Positive lookahead */ - bravalue = OP_ASSERT; - ptr++; - break; - - case '!': /* Negative lookahead */ - bravalue = OP_ASSERT_NOT; - ptr++; - break; - - case '<': /* Lookbehinds */ - switch (*(++ptr)) - { - case '=': /* Positive lookbehind */ - bravalue = OP_ASSERTBACK; - ptr++; - break; - - case '!': /* Negative lookbehind */ - bravalue = OP_ASSERTBACK_NOT; - ptr++; - break; - } - break; - - case '>': /* One-time brackets */ - bravalue = OP_ONCE; - ptr++; - break; - - case 'C': /* Callout - may be followed by digits; */ - previous_callout = code; /* Save for later completion */ - after_manual_callout = 1; /* Skip one item before completing */ - *code++ = OP_CALLOUT; /* Already checked that the terminating */ - { /* closing parenthesis is present. */ - int n = 0; - while ((digitab[*(++ptr)] & ctype_digit) != 0) - n = n * 10 + *ptr - '0'; - if (n > 255) - { - *errorptr = ERR38; - goto FAILED; - } - *code++ = n; - PUT(code, 0, ptr - cd->start_pattern + 1); /* Pattern offset */ - PUT(code, LINK_SIZE, 0); /* Default length */ - code += 2 * LINK_SIZE; - } - previous = NULL; - continue; - - case 'P': /* Named subpattern handling */ - if (*(++ptr) == '<') /* Definition */ - { - int i, namelen; - uschar *slot = cd->name_table; - const uschar *name; /* Don't amalgamate; some compilers */ - name = ++ptr; /* grumble at autoincrement in declaration */ - - while (*ptr++ != '>'); - namelen = ptr - name - 1; - - for (i = 0; i < cd->names_found; i++) - { - int crc = memcmp(name, slot+2, namelen); - if (crc == 0) - { - if (slot[2+namelen] == 0) - { - *errorptr = ERR43; - goto FAILED; - } - crc = -1; /* Current name is substring */ - } - if (crc < 0) - { - memmove(slot + cd->name_entry_size, slot, - (cd->names_found - i) * cd->name_entry_size); - break; - } - slot += cd->name_entry_size; - } - - PUT2(slot, 0, *brackets + 1); - memcpy(slot + 2, name, namelen); - slot[2+namelen] = 0; - cd->names_found++; - goto NUMBERED_GROUP; - } - - if (*ptr == '=' || *ptr == '>') /* Reference or recursion */ - { - int i, namelen; - int type = *ptr++; - const uschar *name = ptr; - uschar *slot = cd->name_table; - - while (*ptr != ')') ptr++; - namelen = ptr - name; - - for (i = 0; i < cd->names_found; i++) - { - if (strncmp((char *)name, (char *)slot+2, namelen) == 0) break; - slot += cd->name_entry_size; - } - if (i >= cd->names_found) - { - *errorptr = ERR15; - goto FAILED; - } - - recno = GET2(slot, 0); - - if (type == '>') goto HANDLE_RECURSION; /* A few lines below */ - - /* Back reference */ - - previous = code; - *code++ = OP_REF; - PUT2INC(code, 0, recno); - cd->backref_map |= (recno < 32)? (1 << recno) : 1; - if (recno > cd->top_backref) cd->top_backref = recno; - continue; - } - - /* Should never happen */ - break; - - case 'R': /* Pattern recursion */ - ptr++; /* Same as (?0) */ - /* Fall through */ - - /* Recursion or "subroutine" call */ - - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - { - const uschar *called; - recno = 0; - while((digitab[*ptr] & ctype_digit) != 0) - recno = recno * 10 + *ptr++ - '0'; - - /* Come here from code above that handles a named recursion */ - - HANDLE_RECURSION: - - previous = code; - - /* Find the bracket that is being referenced. Temporarily end the - regex in case it doesn't exist. */ - - *code = OP_END; - called = (recno == 0)? - cd->start_code : find_bracket(cd->start_code, utf8, recno); - - if (called == NULL) - { - *errorptr = ERR15; - goto FAILED; - } - - /* If the subpattern is still open, this is a recursive call. We - check to see if this is a left recursion that could loop for ever, - and diagnose that case. */ - - if (GET(called, 1) == 0 && could_be_empty(called, code, bcptr, utf8)) - { - *errorptr = ERR40; - goto FAILED; - } - - /* Insert the recursion/subroutine item */ - - *code = OP_RECURSE; - PUT(code, 1, called - cd->start_code); - code += 1 + LINK_SIZE; - } - continue; - - /* Character after (? not specially recognized */ - - default: /* Option setting */ - set = unset = 0; - optset = &set; - - while (*ptr != ')' && *ptr != ':') - { - switch (*ptr++) - { - case '-': optset = &unset; break; - - case 'i': *optset |= PCRE_CASELESS; break; - case 'm': *optset |= PCRE_MULTILINE; break; - case 's': *optset |= PCRE_DOTALL; break; - case 'x': *optset |= PCRE_EXTENDED; break; - case 'U': *optset |= PCRE_UNGREEDY; break; - case 'X': *optset |= PCRE_EXTRA; break; - } - } - - /* Set up the changed option bits, but don't change anything yet. */ - - newoptions = (options | set) & (~unset); - - /* If the options ended with ')' this is not the start of a nested - group with option changes, so the options change at this level. Compile - code to change the ims options if this setting actually changes any of - them. We also pass the new setting back so that it can be put at the - start of any following branches, and when this group ends (if we are in - a group), a resetting item can be compiled. - - Note that if this item is right at the start of the pattern, the - options will have been abstracted and made global, so there will be no - change to compile. */ - - if (*ptr == ')') - { - if ((options & PCRE_IMS) != (newoptions & PCRE_IMS)) - { - *code++ = OP_OPT; - *code++ = newoptions & PCRE_IMS; - } - - /* Change options at this level, and pass them back for use - in subsequent branches. Reset the greedy defaults and the case - value for firstbyte and reqbyte. */ - - *optionsptr = options = newoptions; - greedy_default = ((newoptions & PCRE_UNGREEDY) != 0); - greedy_non_default = greedy_default ^ 1; - req_caseopt = ((options & PCRE_CASELESS) != 0)? REQ_CASELESS : 0; - - previous = NULL; /* This item can't be repeated */ - continue; /* It is complete */ - } - - /* If the options ended with ':' we are heading into a nested group - with possible change of options. Such groups are non-capturing and are - not assertions of any kind. All we need to do is skip over the ':'; - the newoptions value is handled below. */ - - bravalue = OP_BRA; - ptr++; - } - } - - /* If PCRE_NO_AUTO_CAPTURE is set, all unadorned brackets become - non-capturing and behave like (?:...) brackets */ - - else if ((options & PCRE_NO_AUTO_CAPTURE) != 0) - { - bravalue = OP_BRA; - } - - /* Else we have a referencing group; adjust the opcode. If the bracket - number is greater than EXTRACT_BASIC_MAX, we set the opcode one higher, and - arrange for the true number to follow later, in an OP_BRANUMBER item. */ - - else - { - NUMBERED_GROUP: - if (++(*brackets) > EXTRACT_BASIC_MAX) - { - bravalue = OP_BRA + EXTRACT_BASIC_MAX + 1; - code[1+LINK_SIZE] = OP_BRANUMBER; - PUT2(code, 2+LINK_SIZE, *brackets); - skipbytes = 3; - } - else bravalue = OP_BRA + *brackets; - } - - /* Process nested bracketed re. Assertions may not be repeated, but other - kinds can be. We copy code into a non-register variable in order to be able - to pass its address because some compilers complain otherwise. Pass in a - new setting for the ims options if they have changed. */ - - previous = (bravalue >= OP_ONCE)? code : NULL; - *code = bravalue; - tempcode = code; - tempreqvary = cd->req_varyopt; /* Save value before bracket */ - - if (!compile_regex( - newoptions, /* The complete new option state */ - options & PCRE_IMS, /* The previous ims option state */ - brackets, /* Extracting bracket count */ - &tempcode, /* Where to put code (updated) */ - &ptr, /* Input pointer (updated) */ - errorptr, /* Where to put an error message */ - (bravalue == OP_ASSERTBACK || - bravalue == OP_ASSERTBACK_NOT), /* TRUE if back assert */ - skipbytes, /* Skip over OP_COND/OP_BRANUMBER */ - &subfirstbyte, /* For possible first char */ - &subreqbyte, /* For possible last char */ - bcptr, /* Current branch chain */ - cd)) /* Tables block */ - goto FAILED; - - /* At the end of compiling, code is still pointing to the start of the - group, while tempcode has been updated to point past the end of the group - and any option resetting that may follow it. The pattern pointer (ptr) - is on the bracket. */ - - /* If this is a conditional bracket, check that there are no more than - two branches in the group. */ - - else if (bravalue == OP_COND) - { - uschar *tc = code; - condcount = 0; - - do { - condcount++; - tc += GET(tc,1); - } - while (*tc != OP_KET); - - if (condcount > 2) - { - *errorptr = ERR27; - goto FAILED; - } - - /* If there is just one branch, we must not make use of its firstbyte or - reqbyte, because this is equivalent to an empty second branch. */ - - if (condcount == 1) subfirstbyte = subreqbyte = REQ_NONE; - } - - /* Handle updating of the required and first characters. Update for normal - brackets of all kinds, and conditions with two branches (see code above). - If the bracket is followed by a quantifier with zero repeat, we have to - back off. Hence the definition of zeroreqbyte and zerofirstbyte outside the - main loop so that they can be accessed for the back off. */ - - zeroreqbyte = reqbyte; - zerofirstbyte = firstbyte; - groupsetfirstbyte = FALSE; - - if (bravalue >= OP_BRA || bravalue == OP_ONCE || bravalue == OP_COND) - { - /* If we have not yet set a firstbyte in this branch, take it from the - subpattern, remembering that it was set here so that a repeat of more - than one can replicate it as reqbyte if necessary. If the subpattern has - no firstbyte, set "none" for the whole branch. In both cases, a zero - repeat forces firstbyte to "none". */ - - if (firstbyte == REQ_UNSET) - { - if (subfirstbyte >= 0) - { - firstbyte = subfirstbyte; - groupsetfirstbyte = TRUE; - } - else firstbyte = REQ_NONE; - zerofirstbyte = REQ_NONE; - } - - /* If firstbyte was previously set, convert the subpattern's firstbyte - into reqbyte if there wasn't one, using the vary flag that was in - existence beforehand. */ - - else if (subfirstbyte >= 0 && subreqbyte < 0) - subreqbyte = subfirstbyte | tempreqvary; - - /* If the subpattern set a required byte (or set a first byte that isn't - really the first byte - see above), set it. */ - - if (subreqbyte >= 0) reqbyte = subreqbyte; - } - - /* For a forward assertion, we take the reqbyte, if set. This can be - helpful if the pattern that follows the assertion doesn't set a different - char. For example, it's useful for /(?=abcde).+/. We can't set firstbyte - for an assertion, however because it leads to incorrect effect for patterns - such as /(?=a)a.+/ when the "real" "a" would then become a reqbyte instead - of a firstbyte. This is overcome by a scan at the end if there's no - firstbyte, looking for an asserted first char. */ - - else if (bravalue == OP_ASSERT && subreqbyte >= 0) reqbyte = subreqbyte; - - /* Now update the main code pointer to the end of the group. */ - - code = tempcode; - - /* Error if hit end of pattern */ - - if (*ptr != ')') - { - *errorptr = ERR14; - goto FAILED; - } - break; - - /* Check \ for being a real metacharacter; if not, fall through and handle - it as a data character at the start of a string. Escape items are checked - for validity in the pre-compiling pass. */ - - case '\\': - tempptr = ptr; - c = check_escape(&ptr, errorptr, *brackets, options, FALSE); - - /* Handle metacharacters introduced by \. For ones like \d, the ESC_ values - are arranged to be the negation of the corresponding OP_values. For the - back references, the values are ESC_REF plus the reference number. Only - back references and those types that consume a character may be repeated. - We can test for values between ESC_b and ESC_Z for the latter; this may - have to change if any new ones are ever created. */ - - if (c < 0) - { - if (-c == ESC_Q) /* Handle start of quoted string */ - { - if (ptr[1] == '\\' && ptr[2] == 'E') ptr += 2; /* avoid empty string */ - else inescq = TRUE; - continue; - } - - /* For metasequences that actually match a character, we disable the - setting of a first character if it hasn't already been set. */ - - if (firstbyte == REQ_UNSET && -c > ESC_b && -c < ESC_Z) - firstbyte = REQ_NONE; - - /* Set values to reset to if this is followed by a zero repeat. */ - - zerofirstbyte = firstbyte; - zeroreqbyte = reqbyte; - - /* Back references are handled specially */ - - if (-c >= ESC_REF) - { - int number = -c - ESC_REF; - previous = code; - *code++ = OP_REF; - PUT2INC(code, 0, number); - } - - /* So are Unicode property matches, if supported. We know that get_ucp - won't fail because it was tested in the pre-pass. */ - -#ifdef SUPPORT_UCP - else if (-c == ESC_P || -c == ESC_p) - { - BOOL negated; - int value = get_ucp(&ptr, &negated, errorptr); - previous = code; - *code++ = ((-c == ESC_p) != negated)? OP_PROP : OP_NOTPROP; - *code++ = value; - } -#endif - - /* For the rest, we can obtain the OP value by negating the escape - value */ - - else - { - previous = (-c > ESC_b && -c < ESC_Z)? code : NULL; - *code++ = -c; - } - continue; - } - - /* We have a data character whose value is in c. In UTF-8 mode it may have - a value > 127. We set its representation in the length/buffer, and then - handle it as a data character. */ - -#ifdef SUPPORT_UTF8 - if (utf8 && c > 127) - mclength = ord2utf8(c, mcbuffer); - else -#endif - - { - mcbuffer[0] = c; - mclength = 1; - } - - goto ONE_CHAR; - - /* Handle a literal character. It is guaranteed not to be whitespace or # - when the extended flag is set. If we are in UTF-8 mode, it may be a - multi-byte literal character. */ - - default: - NORMAL_CHAR: - mclength = 1; - mcbuffer[0] = c; - -#ifdef SUPPORT_UTF8 - if (utf8 && (c & 0xc0) == 0xc0) - { - while ((ptr[1] & 0xc0) == 0x80) - mcbuffer[mclength++] = *(++ptr); - } -#endif - - /* At this point we have the character's bytes in mcbuffer, and the length - in mclength. When not in UTF-8 mode, the length is always 1. */ - - ONE_CHAR: - previous = code; - *code++ = ((options & PCRE_CASELESS) != 0)? OP_CHARNC : OP_CHAR; - for (c = 0; c < mclength; c++) *code++ = mcbuffer[c]; - - /* Set the first and required bytes appropriately. If no previous first - byte, set it from this character, but revert to none on a zero repeat. - Otherwise, leave the firstbyte value alone, and don't change it on a zero - repeat. */ - - if (firstbyte == REQ_UNSET) - { - zerofirstbyte = REQ_NONE; - zeroreqbyte = reqbyte; - - /* If the character is more than one byte long, we can set firstbyte - only if it is not to be matched caselessly. */ - - if (mclength == 1 || req_caseopt == 0) - { - firstbyte = mcbuffer[0] | req_caseopt; - if (mclength != 1) reqbyte = code[-1] | cd->req_varyopt; - } - else firstbyte = reqbyte = REQ_NONE; - } - - /* firstbyte was previously set; we can set reqbyte only the length is - 1 or the matching is caseful. */ - - else - { - zerofirstbyte = firstbyte; - zeroreqbyte = reqbyte; - if (mclength == 1 || req_caseopt == 0) - reqbyte = code[-1] | req_caseopt | cd->req_varyopt; - } - - break; /* End of literal character handling */ - } - } /* end of big loop */ - -/* Control never reaches here by falling through, only by a goto for all the -error states. Pass back the position in the pattern so that it can be displayed -to the user for diagnosing the error. */ - -FAILED: -*ptrptr = ptr; -return FALSE; -} - - - - -/************************************************* -* Compile sequence of alternatives * -*************************************************/ - -/* On entry, ptr is pointing past the bracket character, but on return -it points to the closing bracket, or vertical bar, or end of string. -The code variable is pointing at the byte into which the BRA operator has been -stored. If the ims options are changed at the start (for a (?ims: group) or -during any branch, we need to insert an OP_OPT item at the start of every -following branch to ensure they get set correctly at run time, and also pass -the new options into every subsequent branch compile. - -Argument: - options option bits, including any changes for this subpattern - oldims previous settings of ims option bits - brackets -> int containing the number of extracting brackets used - codeptr -> the address of the current code pointer - ptrptr -> the address of the current pattern pointer - errorptr -> pointer to error message - lookbehind TRUE if this is a lookbehind assertion - skipbytes skip this many bytes at start (for OP_COND, OP_BRANUMBER) - firstbyteptr place to put the first required character, or a negative number - reqbyteptr place to put the last required character, or a negative number - bcptr pointer to the chain of currently open branches - cd points to the data block with tables pointers etc. - -Returns: TRUE on success -*/ - -static BOOL -compile_regex(int options, int oldims, int *brackets, uschar **codeptr, - const uschar **ptrptr, const char **errorptr, BOOL lookbehind, int skipbytes, - int *firstbyteptr, int *reqbyteptr, branch_chain *bcptr, compile_data *cd) -{ -const uschar *ptr = *ptrptr; -uschar *code = *codeptr; -uschar *last_branch = code; -uschar *start_bracket = code; -uschar *reverse_count = NULL; -int firstbyte, reqbyte; -int branchfirstbyte, branchreqbyte; -branch_chain bc; - -bc.outer = bcptr; -bc.current = code; - -firstbyte = reqbyte = REQ_UNSET; - -/* Offset is set zero to mark that this bracket is still open */ - -PUT(code, 1, 0); -code += 1 + LINK_SIZE + skipbytes; - -/* Loop for each alternative branch */ - -for (;;) - { - /* Handle a change of ims options at the start of the branch */ - - if ((options & PCRE_IMS) != oldims) - { - *code++ = OP_OPT; - *code++ = options & PCRE_IMS; - } - - /* Set up dummy OP_REVERSE if lookbehind assertion */ - - if (lookbehind) - { - *code++ = OP_REVERSE; - reverse_count = code; - PUTINC(code, 0, 0); - } - - /* Now compile the branch */ - - if (!compile_branch(&options, brackets, &code, &ptr, errorptr, - &branchfirstbyte, &branchreqbyte, &bc, cd)) - { - *ptrptr = ptr; - return FALSE; - } - - /* If this is the first branch, the firstbyte and reqbyte values for the - branch become the values for the regex. */ - - if (*last_branch != OP_ALT) - { - firstbyte = branchfirstbyte; - reqbyte = branchreqbyte; - } - - /* If this is not the first branch, the first char and reqbyte have to - match the values from all the previous branches, except that if the previous - value for reqbyte didn't have REQ_VARY set, it can still match, and we set - REQ_VARY for the regex. */ - - else - { - /* If we previously had a firstbyte, but it doesn't match the new branch, - we have to abandon the firstbyte for the regex, but if there was previously - no reqbyte, it takes on the value of the old firstbyte. */ - - if (firstbyte >= 0 && firstbyte != branchfirstbyte) - { - if (reqbyte < 0) reqbyte = firstbyte; - firstbyte = REQ_NONE; - } - - /* If we (now or from before) have no firstbyte, a firstbyte from the - branch becomes a reqbyte if there isn't a branch reqbyte. */ - - if (firstbyte < 0 && branchfirstbyte >= 0 && branchreqbyte < 0) - branchreqbyte = branchfirstbyte; - - /* Now ensure that the reqbytes match */ - - if ((reqbyte & ~REQ_VARY) != (branchreqbyte & ~REQ_VARY)) - reqbyte = REQ_NONE; - else reqbyte |= branchreqbyte; /* To "or" REQ_VARY */ - } - - /* If lookbehind, check that this branch matches a fixed-length string, - and put the length into the OP_REVERSE item. Temporarily mark the end of - the branch with OP_END. */ - - if (lookbehind) - { - int length; - *code = OP_END; - length = find_fixedlength(last_branch, options); - DPRINTF(("fixed length = %d\n", length)); - if (length < 0) - { - *errorptr = (length == -2)? ERR36 : ERR25; - *ptrptr = ptr; - return FALSE; - } - PUT(reverse_count, 0, length); - } - - /* Reached end of expression, either ')' or end of pattern. Go back through - the alternative branches and reverse the chain of offsets, with the field in - the BRA item now becoming an offset to the first alternative. If there are - no alternatives, it points to the end of the group. The length in the - terminating ket is always the length of the whole bracketed item. If any of - the ims options were changed inside the group, compile a resetting op-code - following, except at the very end of the pattern. Return leaving the pointer - at the terminating char. */ - - if (*ptr != '|') - { - int length = code - last_branch; - do - { - int prev_length = GET(last_branch, 1); - PUT(last_branch, 1, length); - length = prev_length; - last_branch -= length; - } - while (length > 0); - - /* Fill in the ket */ - - *code = OP_KET; - PUT(code, 1, code - start_bracket); - code += 1 + LINK_SIZE; - - /* Resetting option if needed */ - - if ((options & PCRE_IMS) != oldims && *ptr == ')') - { - *code++ = OP_OPT; - *code++ = oldims; - } - - /* Set values to pass back */ - - *codeptr = code; - *ptrptr = ptr; - *firstbyteptr = firstbyte; - *reqbyteptr = reqbyte; - return TRUE; - } - - /* Another branch follows; insert an "or" node. Its length field points back - to the previous branch while the bracket remains open. At the end the chain - is reversed. It's done like this so that the start of the bracket has a - zero offset until it is closed, making it possible to detect recursion. */ - - *code = OP_ALT; - PUT(code, 1, code - last_branch); - bc.current = last_branch = code; - code += 1 + LINK_SIZE; - ptr++; - } -/* Control never reaches here */ -} - - - - -/************************************************* -* Check for anchored expression * -*************************************************/ - -/* Try to find out if this is an anchored regular expression. Consider each -alternative branch. If they all start with OP_SOD or OP_CIRC, or with a bracket -all of whose alternatives start with OP_SOD or OP_CIRC (recurse ad lib), then -it's anchored. However, if this is a multiline pattern, then only OP_SOD -counts, since OP_CIRC can match in the middle. - -We can also consider a regex to be anchored if OP_SOM starts all its branches. -This is the code for \G, which means "match at start of match position, taking -into account the match offset". - -A branch is also implicitly anchored if it starts with .* and DOTALL is set, -because that will try the rest of the pattern at all possible matching points, -so there is no point trying again.... er .... - -.... except when the .* appears inside capturing parentheses, and there is a -subsequent back reference to those parentheses. We haven't enough information -to catch that case precisely. - -At first, the best we could do was to detect when .* was in capturing brackets -and the highest back reference was greater than or equal to that level. -However, by keeping a bitmap of the first 31 back references, we can catch some -of the more common cases more precisely. - -Arguments: - code points to start of expression (the bracket) - options points to the options setting - bracket_map a bitmap of which brackets we are inside while testing; this - handles up to substring 31; after that we just have to take - the less precise approach - backref_map the back reference bitmap - -Returns: TRUE or FALSE -*/ - -static BOOL -is_anchored(register const uschar *code, int *options, unsigned int bracket_map, - unsigned int backref_map) -{ -do { - const uschar *scode = - first_significant_code(code + 1+LINK_SIZE, options, PCRE_MULTILINE, FALSE); - register int op = *scode; - - /* Capturing brackets */ - - if (op > OP_BRA) - { - int new_map; - op -= OP_BRA; - if (op > EXTRACT_BASIC_MAX) op = GET2(scode, 2+LINK_SIZE); - new_map = bracket_map | ((op < 32)? (1 << op) : 1); - if (!is_anchored(scode, options, new_map, backref_map)) return FALSE; - } - - /* Other brackets */ - - else if (op == OP_BRA || op == OP_ASSERT || op == OP_ONCE || op == OP_COND) - { - if (!is_anchored(scode, options, bracket_map, backref_map)) return FALSE; - } - - /* .* is not anchored unless DOTALL is set and it isn't in brackets that - are or may be referenced. */ - - else if ((op == OP_TYPESTAR || op == OP_TYPEMINSTAR) && - (*options & PCRE_DOTALL) != 0) - { - if (scode[1] != OP_ANY || (bracket_map & backref_map) != 0) return FALSE; - } - - /* Check for explicit anchoring */ - - else if (op != OP_SOD && op != OP_SOM && - ((*options & PCRE_MULTILINE) != 0 || op != OP_CIRC)) - return FALSE; - code += GET(code, 1); - } -while (*code == OP_ALT); /* Loop for each alternative */ -return TRUE; -} - - - -/************************************************* -* Check for starting with ^ or .* * -*************************************************/ - -/* This is called to find out if every branch starts with ^ or .* so that -"first char" processing can be done to speed things up in multiline -matching and for non-DOTALL patterns that start with .* (which must start at -the beginning or after \n). As in the case of is_anchored() (see above), we -have to take account of back references to capturing brackets that contain .* -because in that case we can't make the assumption. - -Arguments: - code points to start of expression (the bracket) - bracket_map a bitmap of which brackets we are inside while testing; this - handles up to substring 31; after that we just have to take - the less precise approach - backref_map the back reference bitmap - -Returns: TRUE or FALSE -*/ - -static BOOL -is_startline(const uschar *code, unsigned int bracket_map, - unsigned int backref_map) -{ -do { - const uschar *scode = first_significant_code(code + 1+LINK_SIZE, NULL, 0, - FALSE); - register int op = *scode; - - /* Capturing brackets */ - - if (op > OP_BRA) - { - int new_map; - op -= OP_BRA; - if (op > EXTRACT_BASIC_MAX) op = GET2(scode, 2+LINK_SIZE); - new_map = bracket_map | ((op < 32)? (1 << op) : 1); - if (!is_startline(scode, new_map, backref_map)) return FALSE; - } - - /* Other brackets */ - - else if (op == OP_BRA || op == OP_ASSERT || op == OP_ONCE || op == OP_COND) - { if (!is_startline(scode, bracket_map, backref_map)) return FALSE; } - - /* .* means "start at start or after \n" if it isn't in brackets that - may be referenced. */ - - else if (op == OP_TYPESTAR || op == OP_TYPEMINSTAR) - { - if (scode[1] != OP_ANY || (bracket_map & backref_map) != 0) return FALSE; - } - - /* Check for explicit circumflex */ - - else if (op != OP_CIRC) return FALSE; - - /* Move on to the next alternative */ - - code += GET(code, 1); - } -while (*code == OP_ALT); /* Loop for each alternative */ -return TRUE; -} - - - -/************************************************* -* Check for asserted fixed first char * -*************************************************/ - -/* During compilation, the "first char" settings from forward assertions are -discarded, because they can cause conflicts with actual literals that follow. -However, if we end up without a first char setting for an unanchored pattern, -it is worth scanning the regex to see if there is an initial asserted first -char. If all branches start with the same asserted char, or with a bracket all -of whose alternatives start with the same asserted char (recurse ad lib), then -we return that char, otherwise -1. - -Arguments: - code points to start of expression (the bracket) - options pointer to the options (used to check casing changes) - inassert TRUE if in an assertion - -Returns: -1 or the fixed first char -*/ - -static int -find_firstassertedchar(const uschar *code, int *options, BOOL inassert) -{ -register int c = -1; -do { - int d; - const uschar *scode = - first_significant_code(code + 1+LINK_SIZE, options, PCRE_CASELESS, TRUE); - register int op = *scode; - - if (op >= OP_BRA) op = OP_BRA; - - switch(op) - { - default: - return -1; - - case OP_BRA: - case OP_ASSERT: - case OP_ONCE: - case OP_COND: - if ((d = find_firstassertedchar(scode, options, op == OP_ASSERT)) < 0) - return -1; - if (c < 0) c = d; else if (c != d) return -1; - break; - - case OP_EXACT: /* Fall through */ - scode += 2; - - case OP_CHAR: - case OP_CHARNC: - case OP_PLUS: - case OP_MINPLUS: - if (!inassert) return -1; - if (c < 0) - { - c = scode[1]; - if ((*options & PCRE_CASELESS) != 0) c |= REQ_CASELESS; - } - else if (c != scode[1]) return -1; - break; - } - - code += GET(code, 1); - } -while (*code == OP_ALT); -return c; -} - - - - -#ifdef SUPPORT_UTF8 -/************************************************* -* Validate a UTF-8 string * -*************************************************/ - -/* This function is called (optionally) at the start of compile or match, to -validate that a supposed UTF-8 string is actually valid. The early check means -that subsequent code can assume it is dealing with a valid string. The check -can be turned off for maximum performance, but then consequences of supplying -an invalid string are then undefined. - -Arguments: - string points to the string - length length of string, or -1 if the string is zero-terminated - -Returns: < 0 if the string is a valid UTF-8 string - >= 0 otherwise; the value is the offset of the bad byte -*/ - -static int -valid_utf8(const uschar *string, int length) -{ -register const uschar *p; - -if (length < 0) - { - for (p = string; *p != 0; p++); - length = p - string; - } - -for (p = string; length-- > 0; p++) - { - register int ab; - register int c = *p; - if (c < 128) continue; - if ((c & 0xc0) != 0xc0) return p - string; - ab = utf8_table4[c & 0x3f]; /* Number of additional bytes */ - if (length < ab) return p - string; - length -= ab; - - /* Check top bits in the second byte */ - if ((*(++p) & 0xc0) != 0x80) return p - string; - - /* Check for overlong sequences for each different length */ - switch (ab) - { - /* Check for xx00 000x */ - case 1: - if ((c & 0x3e) == 0) return p - string; - continue; /* We know there aren't any more bytes to check */ - - /* Check for 1110 0000, xx0x xxxx */ - case 2: - if (c == 0xe0 && (*p & 0x20) == 0) return p - string; - break; - - /* Check for 1111 0000, xx00 xxxx */ - case 3: - if (c == 0xf0 && (*p & 0x30) == 0) return p - string; - break; - - /* Check for 1111 1000, xx00 0xxx */ - case 4: - if (c == 0xf8 && (*p & 0x38) == 0) return p - string; - break; - - /* Check for leading 0xfe or 0xff, and then for 1111 1100, xx00 00xx */ - case 5: - if (c == 0xfe || c == 0xff || - (c == 0xfc && (*p & 0x3c) == 0)) return p - string; - break; - } - - /* Check for valid bytes after the 2nd, if any; all must start 10 */ - while (--ab > 0) - { - if ((*(++p) & 0xc0) != 0x80) return p - string; - } - } - -return -1; -} -#endif - - - -/************************************************* -* Compile a Regular Expression * -*************************************************/ - -/* This function takes a string and returns a pointer to a block of store -holding a compiled version of the expression. - -Arguments: - pattern the regular expression - options various option bits - errorptr pointer to pointer to error text - erroroffset ptr offset in pattern where error was detected - tables pointer to character tables or NULL - -Returns: pointer to compiled data block, or NULL on error, - with errorptr and erroroffset set -*/ - -EXPORT pcre * -pcre_compile(const char *pattern, int options, const char **errorptr, - int *erroroffset, const unsigned char *tables) -{ -real_pcre *re; -int length = 1 + LINK_SIZE; /* For initial BRA plus length */ -/* int runlength; not used L.M. 2004-09-14 */ -int c, firstbyte, reqbyte; -int bracount = 0; -int branch_extra = 0; -int branch_newextra; -int item_count = -1; -int name_count = 0; -int max_name_size = 0; -int lastitemlength = 0; -#ifdef SUPPORT_UTF8 -BOOL utf8; -BOOL class_utf8; -#endif -BOOL inescq = FALSE; -unsigned int brastackptr = 0; -size_t size; -uschar *code; -const uschar *codestart; -const uschar *ptr; -compile_data compile_block; -int brastack[BRASTACK_SIZE]; -uschar bralenstack[BRASTACK_SIZE]; - -/* We can't pass back an error message if errorptr is NULL; I guess the best we -can do is just return NULL. */ - -if (errorptr == NULL) return NULL; -*errorptr = NULL; - -/* However, we can give a message for this error */ - -if (erroroffset == NULL) - { - *errorptr = ERR16; - return NULL; - } -*erroroffset = 0; - -/* Can't support UTF8 unless PCRE has been compiled to include the code. */ - -#ifdef SUPPORT_UTF8 -utf8 = (options & PCRE_UTF8) != 0; -if (utf8 && (options & PCRE_NO_UTF8_CHECK) == 0 && - (*erroroffset = valid_utf8((uschar *)pattern, -1)) >= 0) - { - *errorptr = ERR44; - return NULL; - } -#else -if ((options & PCRE_UTF8) != 0) - { - *errorptr = ERR32; - return NULL; - } -#endif - -if ((options & ~PUBLIC_OPTIONS) != 0) - { - *errorptr = ERR17; - return NULL; - } - -/* Set up pointers to the individual character tables */ - -if (tables == NULL) tables = pcre_default_tables; -compile_block.lcc = tables + lcc_offset; -compile_block.fcc = tables + fcc_offset; -compile_block.cbits = tables + cbits_offset; -compile_block.ctypes = tables + ctypes_offset; - -/* Maximum back reference and backref bitmap. This is updated for numeric -references during the first pass, but for named references during the actual -compile pass. The bitmap records up to 31 back references to help in deciding -whether (.*) can be treated as anchored or not. */ - -compile_block.top_backref = 0; -compile_block.backref_map = 0; - -/* Reflect pattern for debugging output */ - -DPRINTF(("------------------------------------------------------------------\n")); -DPRINTF(("%s\n", pattern)); - -/* The first thing to do is to make a pass over the pattern to compute the -amount of store required to hold the compiled code. This does not have to be -perfect as long as errors are overestimates. At the same time we can detect any -flag settings right at the start, and extract them. Make an attempt to correct -for any counted white space if an "extended" flag setting appears late in the -pattern. We can't be so clever for #-comments. */ - -ptr = (const uschar *)(pattern - 1); -while ((c = *(++ptr)) != 0) - { - int min, max; - int class_optcount; - int bracket_length; - int duplength; - - /* If we are inside a \Q...\E sequence, all chars are literal */ - - if (inescq) - { - if ((options & PCRE_AUTO_CALLOUT) != 0) length += 2 + 2*LINK_SIZE; - goto NORMAL_CHAR; - } - - /* Otherwise, first check for ignored whitespace and comments */ - - if ((options & PCRE_EXTENDED) != 0) - { - if ((compile_block.ctypes[c] & ctype_space) != 0) continue; - if (c == '#') - { - /* The space before the ; is to avoid a warning on a silly compiler - on the Macintosh. */ - while ((c = *(++ptr)) != 0 && c != NEWLINE) ; - if (c == 0) break; - continue; - } - } - - item_count++; /* Is zero for the first non-comment item */ - - /* Allow space for auto callout before every item except quantifiers. */ - - if ((options & PCRE_AUTO_CALLOUT) != 0 && - c != '*' && c != '+' && c != '?' && - (c != '{' || !is_counted_repeat(ptr + 1))) - length += 2 + 2*LINK_SIZE; - - switch(c) - { - /* A backslashed item may be an escaped data character or it may be a - character type. */ - - case '\\': - c = check_escape(&ptr, errorptr, bracount, options, FALSE); - if (*errorptr != NULL) goto PCRE_ERROR_RETURN; - - lastitemlength = 1; /* Default length of last item for repeats */ - - if (c >= 0) /* Data character */ - { - length += 2; /* For a one-byte character */ - -#ifdef SUPPORT_UTF8 - if (utf8 && c > 127) - { - int i; - for (i = 0; i < sizeof(utf8_table1)/sizeof(int); i++) - if (c <= utf8_table1[i]) break; - length += i; - lastitemlength += i; - } -#endif - - continue; - } - - /* If \Q, enter "literal" mode */ - - if (-c == ESC_Q) - { - inescq = TRUE; - continue; - } - - /* \X is supported only if Unicode property support is compiled */ - -#ifndef SUPPORT_UCP - if (-c == ESC_X) - { - *errorptr = ERR45; - goto PCRE_ERROR_RETURN; - } -#endif - - /* \P and \p are for Unicode properties, but only when the support has - been compiled. Each item needs 2 bytes. */ - - else if (-c == ESC_P || -c == ESC_p) - { -#ifdef SUPPORT_UCP - BOOL negated; - length += 2; - lastitemlength = 2; - if (get_ucp(&ptr, &negated, errorptr) < 0) goto PCRE_ERROR_RETURN; - continue; -#else - *errorptr = ERR45; - goto PCRE_ERROR_RETURN; -#endif - } - - /* Other escapes need one byte */ - - length++; - - /* A back reference needs an additional 2 bytes, plus either one or 5 - bytes for a repeat. We also need to keep the value of the highest - back reference. */ - - if (c <= -ESC_REF) - { - int refnum = -c - ESC_REF; - compile_block.backref_map |= (refnum < 32)? (1 << refnum) : 1; - if (refnum > compile_block.top_backref) - compile_block.top_backref = refnum; - length += 2; /* For single back reference */ - if (ptr[1] == '{' && is_counted_repeat(ptr+2)) - { - ptr = read_repeat_counts(ptr+2, &min, &max, errorptr); - if (*errorptr != NULL) goto PCRE_ERROR_RETURN; - if ((min == 0 && (max == 1 || max == -1)) || - (min == 1 && max == -1)) - length++; - else length += 5; - if (ptr[1] == '?') ptr++; - } - } - continue; - - case '^': /* Single-byte metacharacters */ - case '.': - case '$': - length++; - lastitemlength = 1; - continue; - - case '*': /* These repeats won't be after brackets; */ - case '+': /* those are handled separately */ - case '?': - length++; - goto POSESSIVE; /* A few lines below */ - - /* This covers the cases of braced repeats after a single char, metachar, - class, or back reference. */ - - case '{': - if (!is_counted_repeat(ptr+1)) goto NORMAL_CHAR; - ptr = read_repeat_counts(ptr+1, &min, &max, errorptr); - if (*errorptr != NULL) goto PCRE_ERROR_RETURN; - - /* These special cases just insert one extra opcode */ - - if ((min == 0 && (max == 1 || max == -1)) || - (min == 1 && max == -1)) - length++; - - /* These cases might insert additional copies of a preceding character. */ - - else - { - if (min != 1) - { - length -= lastitemlength; /* Uncount the original char or metachar */ - if (min > 0) length += 3 + lastitemlength; - } - length += lastitemlength + ((max > 0)? 3 : 1); - } - - if (ptr[1] == '?') ptr++; /* Needs no extra length */ - - POSESSIVE: /* Test for possessive quantifier */ - if (ptr[1] == '+') - { - ptr++; - length += 2 + 2*LINK_SIZE; /* Allow for atomic brackets */ - } - continue; - - /* An alternation contains an offset to the next branch or ket. If any ims - options changed in the previous branch(es), and/or if we are in a - lookbehind assertion, extra space will be needed at the start of the - branch. This is handled by branch_extra. */ - - case '|': - length += 1 + LINK_SIZE + branch_extra; - continue; - - /* A character class uses 33 characters provided that all the character - values are less than 256. Otherwise, it uses a bit map for low valued - characters, and individual items for others. Don't worry about character - types that aren't allowed in classes - they'll get picked up during the - compile. A character class that contains only one single-byte character - uses 2 or 3 bytes, depending on whether it is negated or not. Notice this - where we can. (In UTF-8 mode we can do this only for chars < 128.) */ - - case '[': - if (*(++ptr) == '^') - { - class_optcount = 10; /* Greater than one */ - ptr++; - } - else class_optcount = 0; - -#ifdef SUPPORT_UTF8 - class_utf8 = FALSE; -#endif - - /* Written as a "do" so that an initial ']' is taken as data */ - - if (*ptr != 0) do - { - /* Inside \Q...\E everything is literal except \E */ - - if (inescq) - { - if (*ptr != '\\' || ptr[1] != 'E') goto GET_ONE_CHARACTER; - inescq = FALSE; - ptr += 1; - continue; - } - - /* Outside \Q...\E, check for escapes */ - - if (*ptr == '\\') - { - c = check_escape(&ptr, errorptr, bracount, options, TRUE); - if (*errorptr != NULL) goto PCRE_ERROR_RETURN; - - /* \b is backspace inside a class; \X is literal */ - - if (-c == ESC_b) c = '\b'; - else if (-c == ESC_X) c = 'X'; - - /* \Q enters quoting mode */ - - else if (-c == ESC_Q) - { - inescq = TRUE; - continue; - } - - /* Handle escapes that turn into characters */ - - if (c >= 0) goto NON_SPECIAL_CHARACTER; - - /* Escapes that are meta-things. The normal ones just affect the - bit map, but Unicode properties require an XCLASS extended item. */ - - else - { - class_optcount = 10; /* \d, \s etc; make sure > 1 */ -#ifdef SUPPORT_UTF8 - if (-c == ESC_p || -c == ESC_P) - { - if (!class_utf8) - { - class_utf8 = TRUE; - length += LINK_SIZE + 2; - } - length += 2; - } -#endif - } - } - - /* Check the syntax for POSIX stuff. The bits we actually handle are - checked during the real compile phase. */ - - else if (*ptr == '[' && check_posix_syntax(ptr, &ptr, &compile_block)) - { - ptr++; - class_optcount = 10; /* Make sure > 1 */ - } - - /* Anything else increments the possible optimization count. We have to - detect ranges here so that we can compute the number of extra ranges for - caseless wide characters when UCP support is available. If there are wide - characters, we are going to have to use an XCLASS, even for single - characters. */ - - else - { - int d; - - GET_ONE_CHARACTER: - -#ifdef SUPPORT_UTF8 - if (utf8) - { - int extra = 0; - GETCHARLEN(c, ptr, extra); - ptr += extra; - } - else c = *ptr; -#else - c = *ptr; -#endif - - /* Come here from handling \ above when it escapes to a char value */ - - NON_SPECIAL_CHARACTER: - class_optcount++; - - d = -1; - if (ptr[1] == '-') - { - uschar const *hyptr = ptr++; - if (ptr[1] == '\\') - { - ptr++; - d = check_escape(&ptr, errorptr, bracount, options, TRUE); - if (*errorptr != NULL) goto PCRE_ERROR_RETURN; - if (-d == ESC_b) d = '\b'; /* backspace */ - else if (-d == ESC_X) d = 'X'; /* literal X in a class */ - } - else if (ptr[1] != 0 && ptr[1] != ']') - { - ptr++; -#ifdef SUPPORT_UTF8 - if (utf8) - { - int extra = 0; - GETCHARLEN(d, ptr, extra); - ptr += extra; - } - else -#endif - d = *ptr; - } - if (d < 0) ptr = hyptr; /* go back to hyphen as data */ - } - - /* If d >= 0 we have a range. In UTF-8 mode, if the end is > 255, or > - 127 for caseless matching, we will need to use an XCLASS. */ - - if (d >= 0) - { - class_optcount = 10; /* Ensure > 1 */ - if (d < c) - { - *errorptr = ERR8; - goto PCRE_ERROR_RETURN; - } - -#ifdef SUPPORT_UTF8 - if (utf8 && (d > 255 || ((options & PCRE_CASELESS) != 0 && d > 127))) - { - uschar buffer[6]; - if (!class_utf8) /* Allow for XCLASS overhead */ - { - class_utf8 = TRUE; - length += LINK_SIZE + 2; - } - -#ifdef SUPPORT_UCP - /* If we have UCP support, find out how many extra ranges are - needed to map the other case of characters within this range. We - have to mimic the range optimization here, because extending the - range upwards might push d over a boundary that makes is use - another byte in the UTF-8 representation. */ - - if ((options & PCRE_CASELESS) != 0) - { - int occ, ocd; - int cc = c; - int origd = d; - while (get_othercase_range(&cc, origd, &occ, &ocd)) - { - if (occ >= c && ocd <= d) continue; /* Skip embedded */ - - if (occ < c && ocd >= c - 1) /* Extend the basic range */ - { /* if there is overlap, */ - c = occ; /* noting that if occ < c */ - continue; /* we can't have ocd > d */ - } /* because a subrange is */ - if (ocd > d && occ <= d + 1) /* always shorter than */ - { /* the basic range. */ - d = ocd; - continue; - } - - /* An extra item is needed */ - - length += 1 + ord2utf8(occ, buffer) + - ((occ == ocd)? 0 : ord2utf8(ocd, buffer)); - } - } -#endif /* SUPPORT_UCP */ - - /* The length of the (possibly extended) range */ - - length += 1 + ord2utf8(c, buffer) + ord2utf8(d, buffer); - } -#endif /* SUPPORT_UTF8 */ - - } - - /* We have a single character. There is nothing to be done unless we - are in UTF-8 mode. If the char is > 255, or 127 when caseless, we must - allow for an XCL_SINGLE item, doubled for caselessness if there is UCP - support. */ - - else - { -#ifdef SUPPORT_UTF8 - if (utf8 && (c > 255 || ((options & PCRE_CASELESS) != 0 && c > 127))) - { - uschar buffer[6]; - class_optcount = 10; /* Ensure > 1 */ - if (!class_utf8) /* Allow for XCLASS overhead */ - { - class_utf8 = TRUE; - length += LINK_SIZE + 2; - } -#ifdef SUPPORT_UCP - length += (((options & PCRE_CASELESS) != 0)? 2 : 1) * - (1 + ord2utf8(c, buffer)); -#else /* SUPPORT_UCP */ - length += 1 + ord2utf8(c, buffer); -#endif /* SUPPORT_UCP */ - } -#endif /* SUPPORT_UTF8 */ - } - } - } - while (*(++ptr) != 0 && (inescq || *ptr != ']')); /* Concludes "do" above */ - - if (*ptr == 0) /* Missing terminating ']' */ - { - *errorptr = ERR6; - goto PCRE_ERROR_RETURN; - } - - /* We can optimize when there was only one optimizable character. Repeats - for positive and negated single one-byte chars are handled by the general - code. Here, we handle repeats for the class opcodes. */ - - if (class_optcount == 1) length += 3; else - { - length += 33; - - /* A repeat needs either 1 or 5 bytes. If it is a possessive quantifier, - we also need extra for wrapping the whole thing in a sub-pattern. */ - - if (*ptr != 0 && ptr[1] == '{' && is_counted_repeat(ptr+2)) - { - ptr = read_repeat_counts(ptr+2, &min, &max, errorptr); - if (*errorptr != NULL) goto PCRE_ERROR_RETURN; - if ((min == 0 && (max == 1 || max == -1)) || - (min == 1 && max == -1)) - length++; - else length += 5; - if (ptr[1] == '+') - { - ptr++; - length += 2 + 2*LINK_SIZE; - } - else if (ptr[1] == '?') ptr++; - } - } - continue; - - /* Brackets may be genuine groups or special things */ - - case '(': - branch_newextra = 0; - bracket_length = 1 + LINK_SIZE; - - /* Handle special forms of bracket, which all start (? */ - - if (ptr[1] == '?') - { - int set, unset; - int *optset; - - switch (c = ptr[2]) - { - /* Skip over comments entirely */ - case '#': - ptr += 3; - while (*ptr != 0 && *ptr != ')') ptr++; - if (*ptr == 0) - { - *errorptr = ERR18; - goto PCRE_ERROR_RETURN; - } - continue; - - /* Non-referencing groups and lookaheads just move the pointer on, and - then behave like a non-special bracket, except that they don't increment - the count of extracting brackets. Ditto for the "once only" bracket, - which is in Perl from version 5.005. */ - - case ':': - case '=': - case '!': - case '>': - ptr += 2; - break; - - /* (?R) specifies a recursive call to the regex, which is an extension - to provide the facility which can be obtained by (?p{perl-code}) in - Perl 5.6. In Perl 5.8 this has become (??{perl-code}). - - From PCRE 4.00, items such as (?3) specify subroutine-like "calls" to - the appropriate numbered brackets. This includes both recursive and - non-recursive calls. (?R) is now synonymous with (?0). */ - - case 'R': - ptr++; - - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - ptr += 2; - if (c != 'R') - while ((digitab[*(++ptr)] & ctype_digit) != 0); - if (*ptr != ')') - { - *errorptr = ERR29; - goto PCRE_ERROR_RETURN; - } - length += 1 + LINK_SIZE; - - /* If this item is quantified, it will get wrapped inside brackets so - as to use the code for quantified brackets. We jump down and use the - code that handles this for real brackets. */ - - if (ptr[1] == '+' || ptr[1] == '*' || ptr[1] == '?' || ptr[1] == '{') - { - length += 2 + 2 * LINK_SIZE; /* to make bracketed */ - duplength = 5 + 3 * LINK_SIZE; - goto HANDLE_QUANTIFIED_BRACKETS; - } - continue; - - /* (?C) is an extension which provides "callout" - to provide a bit of - the functionality of the Perl (?{...}) feature. An optional number may - follow (default is zero). */ - - case 'C': - ptr += 2; - while ((digitab[*(++ptr)] & ctype_digit) != 0); - if (*ptr != ')') - { - *errorptr = ERR39; - goto PCRE_ERROR_RETURN; - } - length += 2 + 2*LINK_SIZE; - continue; - - /* Named subpatterns are an extension copied from Python */ - - case 'P': - ptr += 3; - if (*ptr == '<') - { - const uschar *p; /* Don't amalgamate; some compilers */ - p = ++ptr; /* grumble at autoincrement in declaration */ - while ((compile_block.ctypes[*ptr] & ctype_word) != 0) ptr++; - if (*ptr != '>') - { - *errorptr = ERR42; - goto PCRE_ERROR_RETURN; - } - name_count++; - if (ptr - p > max_name_size) max_name_size = (ptr - p); - break; - } - - if (*ptr == '=' || *ptr == '>') - { - while ((compile_block.ctypes[*(++ptr)] & ctype_word) != 0); - if (*ptr != ')') - { - *errorptr = ERR42; - goto PCRE_ERROR_RETURN; - } - break; - } - - /* Unknown character after (?P */ - - *errorptr = ERR41; - goto PCRE_ERROR_RETURN; - - /* Lookbehinds are in Perl from version 5.005 */ - - case '<': - ptr += 3; - if (*ptr == '=' || *ptr == '!') - { - branch_newextra = 1 + LINK_SIZE; - length += 1 + LINK_SIZE; /* For the first branch */ - break; - } - *errorptr = ERR24; - goto PCRE_ERROR_RETURN; - - /* Conditionals are in Perl from version 5.005. The bracket must either - be followed by a number (for bracket reference) or by an assertion - group, or (a PCRE extension) by 'R' for a recursion test. */ - - case '(': - if (ptr[3] == 'R' && ptr[4] == ')') - { - ptr += 4; - length += 3; - } - else if ((digitab[ptr[3]] & ctype_digit) != 0) - { - ptr += 4; - length += 3; - while ((digitab[*ptr] & ctype_digit) != 0) ptr++; - if (*ptr != ')') - { - *errorptr = ERR26; - goto PCRE_ERROR_RETURN; - } - } - else /* An assertion must follow */ - { - ptr++; /* Can treat like ':' as far as spacing is concerned */ - if (ptr[2] != '?' || - (ptr[3] != '=' && ptr[3] != '!' && ptr[3] != '<') ) - { - ptr += 2; /* To get right offset in message */ - *errorptr = ERR28; - goto PCRE_ERROR_RETURN; - } - } - break; - - /* Else loop checking valid options until ) is met. Anything else is an - error. If we are without any brackets, i.e. at top level, the settings - act as if specified in the options, so massage the options immediately. - This is for backward compatibility with Perl 5.004. */ - - default: - set = unset = 0; - optset = &set; - ptr += 2; - - for (;; ptr++) - { - c = *ptr; - switch (c) - { - case 'i': - *optset |= PCRE_CASELESS; - continue; - - case 'm': - *optset |= PCRE_MULTILINE; - continue; - - case 's': - *optset |= PCRE_DOTALL; - continue; - - case 'x': - *optset |= PCRE_EXTENDED; - continue; - - case 'X': - *optset |= PCRE_EXTRA; - continue; - - case 'U': - *optset |= PCRE_UNGREEDY; - continue; - - case '-': - optset = &unset; - continue; - - /* A termination by ')' indicates an options-setting-only item; if - this is at the very start of the pattern (indicated by item_count - being zero), we use it to set the global options. This is helpful - when analyzing the pattern for first characters, etc. Otherwise - nothing is done here and it is handled during the compiling - process. - - [Historical note: Up to Perl 5.8, options settings at top level - were always global settings, wherever they appeared in the pattern. - That is, they were equivalent to an external setting. From 5.8 - onwards, they apply only to what follows (which is what you might - expect).] */ - - case ')': - if (item_count == 0) - { - options = (options | set) & (~unset); - set = unset = 0; /* To save length */ - item_count--; /* To allow for several */ - } - - /* Fall through */ - - /* A termination by ':' indicates the start of a nested group with - the given options set. This is again handled at compile time, but - we must allow for compiled space if any of the ims options are - set. We also have to allow for resetting space at the end of - the group, which is why 4 is added to the length and not just 2. - If there are several changes of options within the same group, this - will lead to an over-estimate on the length, but this shouldn't - matter very much. We also have to allow for resetting options at - the start of any alternations, which we do by setting - branch_newextra to 2. Finally, we record whether the case-dependent - flag ever changes within the regex. This is used by the "required - character" code. */ - - case ':': - if (((set|unset) & PCRE_IMS) != 0) - { - length += 4; - branch_newextra = 2; - if (((set|unset) & PCRE_CASELESS) != 0) options |= PCRE_ICHANGED; - } - goto END_OPTIONS; - - /* Unrecognized option character */ - - default: - *errorptr = ERR12; - goto PCRE_ERROR_RETURN; - } - } - - /* If we hit a closing bracket, that's it - this is a freestanding - option-setting. We need to ensure that branch_extra is updated if - necessary. The only values branch_newextra can have here are 0 or 2. - If the value is 2, then branch_extra must either be 2 or 5, depending - on whether this is a lookbehind group or not. */ - - END_OPTIONS: - if (c == ')') - { - if (branch_newextra == 2 && - (branch_extra == 0 || branch_extra == 1+LINK_SIZE)) - branch_extra += branch_newextra; - continue; - } - - /* If options were terminated by ':' control comes here. Fall through - to handle the group below. */ - } - } - - /* Extracting brackets must be counted so we can process escapes in a - Perlish way. If the number exceeds EXTRACT_BASIC_MAX we are going to - need an additional 3 bytes of store per extracting bracket. However, if - PCRE_NO_AUTO)CAPTURE is set, unadorned brackets become non-capturing, so we - must leave the count alone (it will aways be zero). */ - - else if ((options & PCRE_NO_AUTO_CAPTURE) == 0) - { - bracount++; - if (bracount > EXTRACT_BASIC_MAX) bracket_length += 3; - } - - /* Save length for computing whole length at end if there's a repeat that - requires duplication of the group. Also save the current value of - branch_extra, and start the new group with the new value. If non-zero, this - will either be 2 for a (?imsx: group, or 3 for a lookbehind assertion. */ - - if (brastackptr >= sizeof(brastack)/sizeof(int)) - { - *errorptr = ERR19; - goto PCRE_ERROR_RETURN; - } - - bralenstack[brastackptr] = branch_extra; - branch_extra = branch_newextra; - - brastack[brastackptr++] = length; - length += bracket_length; - continue; - - /* Handle ket. Look for subsequent max/min; for certain sets of values we - have to replicate this bracket up to that many times. If brastackptr is - 0 this is an unmatched bracket which will generate an error, but take care - not to try to access brastack[-1] when computing the length and restoring - the branch_extra value. */ - - case ')': - length += 1 + LINK_SIZE; - if (brastackptr > 0) - { - duplength = length - brastack[--brastackptr]; - branch_extra = bralenstack[brastackptr]; - } - else duplength = 0; - - /* The following code is also used when a recursion such as (?3) is - followed by a quantifier, because in that case, it has to be wrapped inside - brackets so that the quantifier works. The value of duplength must be - set before arrival. */ - - HANDLE_QUANTIFIED_BRACKETS: - - /* Leave ptr at the final char; for read_repeat_counts this happens - automatically; for the others we need an increment. */ - - if ((c = ptr[1]) == '{' && is_counted_repeat(ptr+2)) - { - ptr = read_repeat_counts(ptr+2, &min, &max, errorptr); - if (*errorptr != NULL) goto PCRE_ERROR_RETURN; - } - else if (c == '*') { min = 0; max = -1; ptr++; } - else if (c == '+') { min = 1; max = -1; ptr++; } - else if (c == '?') { min = 0; max = 1; ptr++; } - else { min = 1; max = 1; } - - /* If the minimum is zero, we have to allow for an OP_BRAZERO before the - group, and if the maximum is greater than zero, we have to replicate - maxval-1 times; each replication acquires an OP_BRAZERO plus a nesting - bracket set. */ - - if (min == 0) - { - length++; - if (max > 0) length += (max - 1) * (duplength + 3 + 2*LINK_SIZE); - } - - /* When the minimum is greater than zero, we have to replicate up to - minval-1 times, with no additions required in the copies. Then, if there - is a limited maximum we have to replicate up to maxval-1 times allowing - for a BRAZERO item before each optional copy and nesting brackets for all - but one of the optional copies. */ - - else - { - length += (min - 1) * duplength; - if (max > min) /* Need this test as max=-1 means no limit */ - length += (max - min) * (duplength + 3 + 2*LINK_SIZE) - - (2 + 2*LINK_SIZE); - } - - /* Allow space for once brackets for "possessive quantifier" */ - - if (ptr[1] == '+') - { - ptr++; - length += 2 + 2*LINK_SIZE; - } - continue; - - /* Non-special character. It won't be space or # in extended mode, so it is - always a genuine character. If we are in a \Q...\E sequence, check for the - end; if not, we have a literal. */ - - default: - NORMAL_CHAR: - - if (inescq && c == '\\' && ptr[1] == 'E') - { - inescq = FALSE; - ptr++; - continue; - } - - length += 2; /* For a one-byte character */ - lastitemlength = 1; /* Default length of last item for repeats */ - - /* In UTF-8 mode, check for additional bytes. */ - -#ifdef SUPPORT_UTF8 - if (utf8 && (c & 0xc0) == 0xc0) - { - while ((ptr[1] & 0xc0) == 0x80) /* Can't flow over the end */ - { /* because the end is marked */ - lastitemlength++; /* by a zero byte. */ - length++; - ptr++; - } - } -#endif - - continue; - } - } - -length += 2 + LINK_SIZE; /* For final KET and END */ - -if ((options & PCRE_AUTO_CALLOUT) != 0) - length += 2 + 2*LINK_SIZE; /* For final callout */ - -if (length > MAX_PATTERN_SIZE) - { - *errorptr = ERR20; - return NULL; - } - -/* Compute the size of data block needed and get it, either from malloc or -externally provided function. */ - -size = length + sizeof(real_pcre) + name_count * (max_name_size + 3); -re = (real_pcre *)(pcre_malloc)(size); - -if (re == NULL) - { - *errorptr = ERR21; - return NULL; - } - -/* Put in the magic number, and save the sizes, options, and character table -pointer. NULL is used for the default character tables. The nullpad field is at -the end; it's there to help in the case when a regex compiled on a system with -4-byte pointers is run on another with 8-byte pointers. */ - -re->magic_number = MAGIC_NUMBER; -re->size = size; -re->options = options; -re->dummy1 = re->dummy2 = 0; -re->name_table_offset = sizeof(real_pcre); -re->name_entry_size = max_name_size + 3; -re->name_count = name_count; -re->tables = (tables == pcre_default_tables)? NULL : tables; -re->nullpad = NULL; - -/* The starting points of the name/number translation table and of the code are -passed around in the compile data block. */ - -compile_block.names_found = 0; -compile_block.name_entry_size = max_name_size + 3; -compile_block.name_table = (uschar *)re + re->name_table_offset; -codestart = compile_block.name_table + re->name_entry_size * re->name_count; -compile_block.start_code = codestart; -compile_block.start_pattern = (const uschar *)pattern; -compile_block.req_varyopt = 0; -compile_block.nopartial = FALSE; - -/* Set up a starting, non-extracting bracket, then compile the expression. On -error, *errorptr will be set non-NULL, so we don't need to look at the result -of the function here. */ - -ptr = (const uschar *)pattern; -code = (uschar *)codestart; -*code = OP_BRA; -bracount = 0; -(void)compile_regex(options, options & PCRE_IMS, &bracount, &code, &ptr, - errorptr, FALSE, 0, &firstbyte, &reqbyte, NULL, &compile_block); -re->top_bracket = bracount; -re->top_backref = compile_block.top_backref; - -if (compile_block.nopartial) re->options |= PCRE_NOPARTIAL; - -/* If not reached end of pattern on success, there's an excess bracket. */ - -if (*errorptr == NULL && *ptr != 0) *errorptr = ERR22; - -/* Fill in the terminating state and check for disastrous overflow, but -if debugging, leave the test till after things are printed out. */ - -*code++ = OP_END; - -#ifndef DEBUG -if (code - codestart > length) *errorptr = ERR23; -#endif - -/* Give an error if there's back reference to a non-existent capturing -subpattern. */ - -if (re->top_backref > re->top_bracket) *errorptr = ERR15; - -/* Failed to compile, or error while post-processing */ - -if (*errorptr != NULL) - { - (pcre_free)(re); - PCRE_ERROR_RETURN: - *erroroffset = ptr - (const uschar *)pattern; - return NULL; - } - -/* If the anchored option was not passed, set the flag if we can determine that -the pattern is anchored by virtue of ^ characters or \A or anything else (such -as starting with .* when DOTALL is set). - -Otherwise, if we know what the first character has to be, save it, because that -speeds up unanchored matches no end. If not, see if we can set the -PCRE_STARTLINE flag. This is helpful for multiline matches when all branches -start with ^. and also when all branches start with .* for non-DOTALL matches. -*/ - -if ((options & PCRE_ANCHORED) == 0) - { - int temp_options = options; - if (is_anchored(codestart, &temp_options, 0, compile_block.backref_map)) - re->options |= PCRE_ANCHORED; - else - { - if (firstbyte < 0) - firstbyte = find_firstassertedchar(codestart, &temp_options, FALSE); - if (firstbyte >= 0) /* Remove caseless flag for non-caseable chars */ - { - int ch = firstbyte & 255; - re->first_byte = ((firstbyte & REQ_CASELESS) != 0 && - compile_block.fcc[ch] == ch)? ch : firstbyte; - re->options |= PCRE_FIRSTSET; - } - else if (is_startline(codestart, 0, compile_block.backref_map)) - re->options |= PCRE_STARTLINE; - } - } - -/* For an anchored pattern, we use the "required byte" only if it follows a -variable length item in the regex. Remove the caseless flag for non-caseable -bytes. */ - -if (reqbyte >= 0 && - ((re->options & PCRE_ANCHORED) == 0 || (reqbyte & REQ_VARY) != 0)) - { - int ch = reqbyte & 255; - re->req_byte = ((reqbyte & REQ_CASELESS) != 0 && - compile_block.fcc[ch] == ch)? (reqbyte & ~REQ_CASELESS) : reqbyte; - re->options |= PCRE_REQCHSET; - } - -/* Print out the compiled data for debugging */ - -#ifdef DEBUG - -printf("Length = %d top_bracket = %d top_backref = %d\n", - length, re->top_bracket, re->top_backref); - -if (re->options != 0) - { - printf("%s%s%s%s%s%s%s%s%s%s\n", - ((re->options & PCRE_NOPARTIAL) != 0)? "nopartial " : "", - ((re->options & PCRE_ANCHORED) != 0)? "anchored " : "", - ((re->options & PCRE_CASELESS) != 0)? "caseless " : "", - ((re->options & PCRE_ICHANGED) != 0)? "case state changed " : "", - ((re->options & PCRE_EXTENDED) != 0)? "extended " : "", - ((re->options & PCRE_MULTILINE) != 0)? "multiline " : "", - ((re->options & PCRE_DOTALL) != 0)? "dotall " : "", - ((re->options & PCRE_DOLLAR_ENDONLY) != 0)? "endonly " : "", - ((re->options & PCRE_EXTRA) != 0)? "extra " : "", - ((re->options & PCRE_UNGREEDY) != 0)? "ungreedy " : ""); - } - -if ((re->options & PCRE_FIRSTSET) != 0) - { - int ch = re->first_byte & 255; - const char *caseless = ((re->first_byte & REQ_CASELESS) == 0)? "" : " (caseless)"; - if (isprint(ch)) printf("First char = %c%s\n", ch, caseless); - else printf("First char = \\x%02x%s\n", ch, caseless); - } - -if ((re->options & PCRE_REQCHSET) != 0) - { - int ch = re->req_byte & 255; - const char *caseless = ((re->req_byte & REQ_CASELESS) == 0)? "" : " (caseless)"; - if (isprint(ch)) printf("Req char = %c%s\n", ch, caseless); - else printf("Req char = \\x%02x%s\n", ch, caseless); - } - -#ifdef DEBUG_PCRE -print_internals(re, stdout); -#endif - -/* This check is done here in the debugging case so that the code that -was compiled can be seen. */ - -if (code - codestart > length) - { - *errorptr = ERR23; - (pcre_free)(re); - *erroroffset = ptr - (uschar *)pattern; - return NULL; - } -#endif - -return (pcre *)re; -} - - - -/************************************************* -* Match a back-reference * -*************************************************/ - -/* If a back reference hasn't been set, the length that is passed is greater -than the number of characters left in the string, so the match fails. - -Arguments: - offset index into the offset vector - eptr points into the subject - length length to be matched - md points to match data block - ims the ims flags - -Returns: TRUE if matched -*/ - -static BOOL -match_ref(int offset, register const uschar *eptr, int length, match_data *md, - unsigned long int ims) -{ -const uschar *p = md->start_subject + md->offset_vector[offset]; - -#ifdef DEBUG -if (eptr >= md->end_subject) - printf("matching subject "); -else - { - printf("matching subject "); - pchars(eptr, length, TRUE, md); - } -printf(" against backref "); -pchars(p, length, FALSE, md); -printf("\n"); -#endif - -/* Always fail if not enough characters left */ - -if (length > md->end_subject - eptr) return FALSE; - -/* Separate the caselesss case for speed */ - -if ((ims & PCRE_CASELESS) != 0) - { - while (length-- > 0) - if (md->lcc[*p++] != md->lcc[*eptr++]) return FALSE; - } -else - { while (length-- > 0) if (*p++ != *eptr++) return FALSE; } - -return TRUE; -} - - -#ifdef SUPPORT_UTF8 -/************************************************* -* Match character against an XCLASS * -*************************************************/ - -/* This function is called from within the XCLASS code below, to match a -character against an extended class which might match values > 255. - -Arguments: - c the character - data points to the flag byte of the XCLASS data - -Returns: TRUE if character matches, else FALSE -*/ - -static BOOL -match_xclass(int c, const uschar *data) -{ -int t; -BOOL negated = (*data & XCL_NOT) != 0; - -/* Character values < 256 are matched against a bitmap, if one is present. If -not, we still carry on, because there may be ranges that start below 256 in the -additional data. */ - -if (c < 256) - { - if ((*data & XCL_MAP) != 0 && (data[1 + c/8] & (1 << (c&7))) != 0) - return !negated; /* char found */ - } - -/* First skip the bit map if present. Then match against the list of Unicode -properties or large chars or ranges that end with a large char. We won't ever -encounter XCL_PROP or XCL_NOTPROP when UCP support is not compiled. */ - -if ((*data++ & XCL_MAP) != 0) data += 32; - -while ((t = *data++) != XCL_END) - { - int x, y; - if (t == XCL_SINGLE) - { - GETCHARINC(x, data); - if (c == x) return !negated; - } - else if (t == XCL_RANGE) - { - GETCHARINC(x, data); - GETCHARINC(y, data); - if (c >= x && c <= y) return !negated; - } - -#ifdef SUPPORT_UCP - else /* XCL_PROP & XCL_NOTPROP */ - { - int chartype, othercase; - int rqdtype = *data++; - int category = ucp_findchar(c, &chartype, &othercase); - if (rqdtype >= 128) - { - if ((rqdtype - 128 == category) == (t == XCL_PROP)) return !negated; - } - else - { - if ((rqdtype == chartype) == (t == XCL_PROP)) return !negated; - } - } -#endif /* SUPPORT_UCP */ - } - -return negated; /* char did not match */ -} -#endif - - -/*************************************************************************** -**************************************************************************** - RECURSION IN THE match() FUNCTION - -The match() function is highly recursive. Some regular expressions can cause -it to recurse thousands of times. I was writing for Unix, so I just let it -call itself recursively. This uses the stack for saving everything that has -to be saved for a recursive call. On Unix, the stack can be large, and this -works fine. - -It turns out that on non-Unix systems there are problems with programs that -use a lot of stack. (This despite the fact that every last chip has oodles -of memory these days, and techniques for extending the stack have been known -for decades.) So.... - -There is a fudge, triggered by defining NO_RECURSE, which avoids recursive -calls by keeping local variables that need to be preserved in blocks of memory -obtained from malloc instead instead of on the stack. Macros are used to -achieve this so that the actual code doesn't look very different to what it -always used to. -**************************************************************************** -***************************************************************************/ - - -/* These versions of the macros use the stack, as normal */ - -#ifndef NO_RECURSE -#define REGISTER register -#define RMATCH(rx,ra,rb,rc,rd,re,rf,rg) rx = match(ra,rb,rc,rd,re,rf,rg) -#define RRETURN(ra) return ra -#else - - -/* These versions of the macros manage a private stack on the heap. Note -that the rd argument of RMATCH isn't actually used. It's the md argument of -match(), which never changes. */ - -#define REGISTER - -#define RMATCH(rx,ra,rb,rc,rd,re,rf,rg)\ - {\ - heapframe *newframe = (pcre_stack_malloc)(sizeof(heapframe));\ - if (setjmp(frame->Xwhere) == 0)\ - {\ - newframe->Xeptr = ra;\ - newframe->Xecode = rb;\ - newframe->Xoffset_top = rc;\ - newframe->Xims = re;\ - newframe->Xeptrb = rf;\ - newframe->Xflags = rg;\ - newframe->Xprevframe = frame;\ - frame = newframe;\ - DPRINTF(("restarting from line %d\n", __LINE__));\ - goto HEAP_RECURSE;\ - }\ - else\ - {\ - DPRINTF(("longjumped back to line %d\n", __LINE__));\ - frame = md->thisframe;\ - rx = frame->Xresult;\ - }\ - } - -#define RRETURN(ra)\ - {\ - heapframe *newframe = frame;\ - frame = newframe->Xprevframe;\ - (pcre_stack_free)(newframe);\ - if (frame != NULL)\ - {\ - frame->Xresult = ra;\ - md->thisframe = frame;\ - longjmp(frame->Xwhere, 1);\ - }\ - return ra;\ - } - - -/* Structure for remembering the local variables in a private frame */ - -typedef struct heapframe { - struct heapframe *Xprevframe; - - /* Function arguments that may change */ - - const uschar *Xeptr; - const uschar *Xecode; - int Xoffset_top; - long int Xims; - eptrblock *Xeptrb; - int Xflags; - - /* Function local variables */ - - const uschar *Xcallpat; - const uschar *Xcharptr; - const uschar *Xdata; - const uschar *Xnext; - const uschar *Xpp; - const uschar *Xprev; - const uschar *Xsaved_eptr; - - recursion_info Xnew_recursive; - - BOOL Xcur_is_word; - BOOL Xcondition; - BOOL Xminimize; - BOOL Xprev_is_word; - - unsigned long int Xoriginal_ims; - -#ifdef SUPPORT_UCP - int Xprop_type; - int Xprop_fail_result; - int Xprop_category; - int Xprop_chartype; - int Xprop_othercase; - int Xprop_test_against; - int *Xprop_test_variable; -#endif - - int Xctype; - int Xfc; - int Xfi; - int Xlength; - int Xmax; - int Xmin; - int Xnumber; - int Xoffset; - int Xop; - int Xsave_capture_last; - int Xsave_offset1, Xsave_offset2, Xsave_offset3; - int Xstacksave[REC_STACK_SAVE_MAX]; - - eptrblock Xnewptrb; - - /* Place to pass back result, and where to jump back to */ - - int Xresult; - jmp_buf Xwhere; - -} heapframe; - -#endif - - -/*************************************************************************** -***************************************************************************/ - - - -/************************************************* -* Match from current position * -*************************************************/ - -/* On entry ecode points to the first opcode, and eptr to the first character -in the subject string, while eptrb holds the value of eptr at the start of the -last bracketed group - used for breaking infinite loops matching zero-length -strings. This function is called recursively in many circumstances. Whenever it -returns a negative (error) response, the outer incarnation must also return the -same response. - -Performance note: It might be tempting to extract commonly used fields from the -md structure (e.g. utf8, end_subject) into individual variables to improve -performance. Tests using gcc on a SPARC disproved this; in the first case, it -made performance worse. - -Arguments: - eptr pointer in subject - ecode position in code - offset_top current top pointer - md pointer to "static" info for the match - ims current /i, /m, and /s options - eptrb pointer to chain of blocks containing eptr at start of - brackets - for testing for empty matches - flags can contain - match_condassert - this is an assertion condition - match_isgroup - this is the start of a bracketed group - -Returns: MATCH_MATCH if matched ) these values are >= 0 - MATCH_NOMATCH if failed to match ) - a negative PCRE_ERROR_xxx value if aborted by an error condition - (e.g. stopped by recursion limit) -*/ - -static int -match(REGISTER const uschar *eptr, REGISTER const uschar *ecode, - int offset_top, match_data *md, unsigned long int ims, eptrblock *eptrb, - int flags) -{ -/* These variables do not need to be preserved over recursion in this function, -so they can be ordinary variables in all cases. Mark them with "register" -because they are used a lot in loops. */ - -register int rrc; /* Returns from recursive calls */ -register int i; /* Used for loops not involving calls to RMATCH() */ -register int c; /* Character values not kept over RMATCH() calls */ - -/* When recursion is not being used, all "local" variables that have to be -preserved over calls to RMATCH() are part of a "frame" which is obtained from -heap storage. Set up the top-level frame here; others are obtained from the -heap whenever RMATCH() does a "recursion". See the macro definitions above. */ - -#ifdef NO_RECURSE -heapframe *frame = (pcre_stack_malloc)(sizeof(heapframe)); -frame->Xprevframe = NULL; /* Marks the top level */ - -/* Copy in the original argument variables */ - -frame->Xeptr = eptr; -frame->Xecode = ecode; -frame->Xoffset_top = offset_top; -frame->Xims = ims; -frame->Xeptrb = eptrb; -frame->Xflags = flags; - -/* This is where control jumps back to to effect "recursion" */ - -HEAP_RECURSE: - -/* Macros make the argument variables come from the current frame */ - -#define eptr frame->Xeptr -#define ecode frame->Xecode -#define offset_top frame->Xoffset_top -#define ims frame->Xims -#define eptrb frame->Xeptrb -#define flags frame->Xflags - -/* Ditto for the local variables */ - -#ifdef SUPPORT_UTF8 -#define charptr frame->Xcharptr -#endif -#define callpat frame->Xcallpat -#define data frame->Xdata -#define next frame->Xnext -#define pp frame->Xpp -#define prev frame->Xprev -#define saved_eptr frame->Xsaved_eptr - -#define new_recursive frame->Xnew_recursive - -#define cur_is_word frame->Xcur_is_word -#define condition frame->Xcondition -#define minimize frame->Xminimize -#define prev_is_word frame->Xprev_is_word - -#define original_ims frame->Xoriginal_ims - -#ifdef SUPPORT_UCP -#define prop_type frame->Xprop_type -#define prop_fail_result frame->Xprop_fail_result -#define prop_category frame->Xprop_category -#define prop_chartype frame->Xprop_chartype -#define prop_othercase frame->Xprop_othercase -#define prop_test_against frame->Xprop_test_against -#define prop_test_variable frame->Xprop_test_variable -#endif - -#define ctype frame->Xctype -#define fc frame->Xfc -#define fi frame->Xfi -#define length frame->Xlength -#define max frame->Xmax -#define min frame->Xmin -#define number frame->Xnumber -#define offset frame->Xoffset -#define op frame->Xop -#define save_capture_last frame->Xsave_capture_last -#define save_offset1 frame->Xsave_offset1 -#define save_offset2 frame->Xsave_offset2 -#define save_offset3 frame->Xsave_offset3 -#define stacksave frame->Xstacksave - -#define newptrb frame->Xnewptrb - -/* When recursion is being used, local variables are allocated on the stack and -get preserved during recursion in the normal way. In this environment, fi and -i, and fc and c, can be the same variables. */ - -#else -#define fi i -#define fc c - - -#ifdef SUPPORT_UTF8 /* Many of these variables are used ony */ -const uschar *charptr; /* small blocks of the code. My normal */ -#endif /* style of coding would have declared */ -const uschar *callpat; /* them within each of those blocks. */ -const uschar *data; /* However, in order to accommodate the */ -const uschar *next; /* version of this code that uses an */ -const uschar *pp; /* external "stack" implemented on the */ -const uschar *prev; /* heap, it is easier to declare them */ -const uschar *saved_eptr; /* all here, so the declarations can */ - /* be cut out in a block. The only */ -recursion_info new_recursive; /* declarations within blocks below are */ - /* for variables that do not have to */ -BOOL cur_is_word; /* be preserved over a recursive call */ -BOOL condition; /* to RMATCH(). */ -BOOL minimize; -BOOL prev_is_word; - -unsigned long int original_ims; - -#ifdef SUPPORT_UCP -int prop_type; -int prop_fail_result; -int prop_category; -int prop_chartype; -int prop_othercase; -int prop_test_against; -int *prop_test_variable; -#endif - -int ctype; -int length; -int max; -int min; -int number; -int offset; -int op; -int save_capture_last; -int save_offset1, save_offset2, save_offset3; -int stacksave[REC_STACK_SAVE_MAX]; - -eptrblock newptrb; -#endif - -/* These statements are here to stop the compiler complaining about unitialized -variables. */ - -#ifdef SUPPORT_UCP -prop_fail_result = 0; -prop_test_against = 0; -prop_test_variable = NULL; -#endif - -/* OK, now we can get on with the real code of the function. Recursion is -specified by the macros RMATCH and RRETURN. When NO_RECURSE is *not* defined, -these just turn into a recursive call to match() and a "return", respectively. -However, RMATCH isn't like a function call because it's quite a complicated -macro. It has to be used in one particular way. This shouldn't, however, impact -performance when true recursion is being used. */ - -if (md->match_call_count++ >= md->match_limit) RRETURN(PCRE_ERROR_MATCHLIMIT); - -original_ims = ims; /* Save for resetting on ')' */ - -/* At the start of a bracketed group, add the current subject pointer to the -stack of such pointers, to be re-instated at the end of the group when we hit -the closing ket. When match() is called in other circumstances, we don't add to -this stack. */ - -if ((flags & match_isgroup) != 0) - { - newptrb.epb_prev = eptrb; - newptrb.epb_saved_eptr = eptr; - eptrb = &newptrb; - } - -/* Now start processing the operations. */ - -for (;;) - { - op = *ecode; - minimize = FALSE; - - /* For partial matching, remember if we ever hit the end of the subject after - matching at least one subject character. */ - - if (md->partial && - eptr >= md->end_subject && - eptr > md->start_match) - md->hitend = TRUE; - - /* Opening capturing bracket. If there is space in the offset vector, save - the current subject position in the working slot at the top of the vector. We - mustn't change the current values of the data slot, because they may be set - from a previous iteration of this group, and be referred to by a reference - inside the group. - - If the bracket fails to match, we need to restore this value and also the - values of the final offsets, in case they were set by a previous iteration of - the same bracket. - - If there isn't enough space in the offset vector, treat this as if it were a - non-capturing bracket. Don't worry about setting the flag for the error case - here; that is handled in the code for KET. */ - - if (op > OP_BRA) - { - number = op - OP_BRA; - - /* For extended extraction brackets (large number), we have to fish out the - number from a dummy opcode at the start. */ - - if (number > EXTRACT_BASIC_MAX) - number = GET2(ecode, 2+LINK_SIZE); - offset = number << 1; - -#ifdef DEBUG - printf("start bracket %d subject=", number); - pchars(eptr, 16, TRUE, md); - printf("\n"); -#endif - - if (offset < md->offset_max) - { - save_offset1 = md->offset_vector[offset]; - save_offset2 = md->offset_vector[offset+1]; - save_offset3 = md->offset_vector[md->offset_end - number]; - save_capture_last = md->capture_last; - - DPRINTF(("saving %d %d %d\n", save_offset1, save_offset2, save_offset3)); - md->offset_vector[md->offset_end - number] = eptr - md->start_subject; - - do - { - RMATCH(rrc, eptr, ecode + 1 + LINK_SIZE, offset_top, md, ims, eptrb, - match_isgroup); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - md->capture_last = save_capture_last; - ecode += GET(ecode, 1); - } - while (*ecode == OP_ALT); - - DPRINTF(("bracket %d failed\n", number)); - - md->offset_vector[offset] = save_offset1; - md->offset_vector[offset+1] = save_offset2; - md->offset_vector[md->offset_end - number] = save_offset3; - - RRETURN(MATCH_NOMATCH); - } - - /* Insufficient room for saving captured contents */ - - else op = OP_BRA; - } - - /* Other types of node can be handled by a switch */ - - switch(op) - { - case OP_BRA: /* Non-capturing bracket: optimized */ - DPRINTF(("start bracket 0\n")); - do - { - RMATCH(rrc, eptr, ecode + 1 + LINK_SIZE, offset_top, md, ims, eptrb, - match_isgroup); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - ecode += GET(ecode, 1); - } - while (*ecode == OP_ALT); - DPRINTF(("bracket 0 failed\n")); - RRETURN(MATCH_NOMATCH); - - /* Conditional group: compilation checked that there are no more than - two branches. If the condition is false, skipping the first branch takes us - past the end if there is only one branch, but that's OK because that is - exactly what going to the ket would do. */ - - case OP_COND: - if (ecode[LINK_SIZE+1] == OP_CREF) /* Condition extract or recurse test */ - { - offset = GET2(ecode, LINK_SIZE+2) << 1; /* Doubled ref number */ - condition = (offset == CREF_RECURSE * 2)? - (md->recursive != NULL) : - (offset < offset_top && md->offset_vector[offset] >= 0); - RMATCH(rrc, eptr, ecode + (condition? - (LINK_SIZE + 4) : (LINK_SIZE + 1 + GET(ecode, 1))), - offset_top, md, ims, eptrb, match_isgroup); - RRETURN(rrc); - } - - /* The condition is an assertion. Call match() to evaluate it - setting - the final argument TRUE causes it to stop at the end of an assertion. */ - - else - { - RMATCH(rrc, eptr, ecode + 1 + LINK_SIZE, offset_top, md, ims, NULL, - match_condassert | match_isgroup); - if (rrc == MATCH_MATCH) - { - ecode += 1 + LINK_SIZE + GET(ecode, LINK_SIZE+2); - while (*ecode == OP_ALT) ecode += GET(ecode, 1); - } - else if (rrc != MATCH_NOMATCH) - { - RRETURN(rrc); /* Need braces because of following else */ - } - else ecode += GET(ecode, 1); - RMATCH(rrc, eptr, ecode + 1 + LINK_SIZE, offset_top, md, ims, eptrb, - match_isgroup); - RRETURN(rrc); - } - /* Control never reaches here */ - - /* Skip over conditional reference or large extraction number data if - encountered. */ - - case OP_CREF: - case OP_BRANUMBER: - ecode += 3; - break; - - /* End of the pattern. If we are in a recursion, we should restore the - offsets appropriately and continue from after the call. */ - - case OP_END: - if (md->recursive != NULL && md->recursive->group_num == 0) - { - recursion_info *rec = md->recursive; - DPRINTF(("Hit the end in a (?0) recursion\n")); - md->recursive = rec->prevrec; - memmove(md->offset_vector, rec->offset_save, - rec->saved_max * sizeof(int)); - md->start_match = rec->save_start; - ims = original_ims; - ecode = rec->after_call; - break; - } - - /* Otherwise, if PCRE_NOTEMPTY is set, fail if we have matched an empty - string - backtracking will then try other alternatives, if any. */ - - if (md->notempty && eptr == md->start_match) RRETURN(MATCH_NOMATCH); - md->end_match_ptr = eptr; /* Record where we ended */ - md->end_offset_top = offset_top; /* and how many extracts were taken */ - RRETURN(MATCH_MATCH); - - /* Change option settings */ - - case OP_OPT: - ims = ecode[1]; - ecode += 2; - DPRINTF(("ims set to %02lx\n", ims)); - break; - - /* Assertion brackets. Check the alternative branches in turn - the - matching won't pass the KET for an assertion. If any one branch matches, - the assertion is true. Lookbehind assertions have an OP_REVERSE item at the - start of each branch to move the current point backwards, so the code at - this level is identical to the lookahead case. */ - - case OP_ASSERT: - case OP_ASSERTBACK: - do - { - RMATCH(rrc, eptr, ecode + 1 + LINK_SIZE, offset_top, md, ims, NULL, - match_isgroup); - if (rrc == MATCH_MATCH) break; - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - ecode += GET(ecode, 1); - } - while (*ecode == OP_ALT); - if (*ecode == OP_KET) RRETURN(MATCH_NOMATCH); - - /* If checking an assertion for a condition, return MATCH_MATCH. */ - - if ((flags & match_condassert) != 0) RRETURN(MATCH_MATCH); - - /* Continue from after the assertion, updating the offsets high water - mark, since extracts may have been taken during the assertion. */ - - do ecode += GET(ecode,1); while (*ecode == OP_ALT); - ecode += 1 + LINK_SIZE; - offset_top = md->end_offset_top; - continue; - - /* Negative assertion: all branches must fail to match */ - - case OP_ASSERT_NOT: - case OP_ASSERTBACK_NOT: - do - { - RMATCH(rrc, eptr, ecode + 1 + LINK_SIZE, offset_top, md, ims, NULL, - match_isgroup); - if (rrc == MATCH_MATCH) RRETURN(MATCH_NOMATCH); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - ecode += GET(ecode,1); - } - while (*ecode == OP_ALT); - - if ((flags & match_condassert) != 0) RRETURN(MATCH_MATCH); - - ecode += 1 + LINK_SIZE; - continue; - - /* Move the subject pointer back. This occurs only at the start of - each branch of a lookbehind assertion. If we are too close to the start to - move back, this match function fails. When working with UTF-8 we move - back a number of characters, not bytes. */ - - case OP_REVERSE: -#ifdef SUPPORT_UTF8 - if (md->utf8) - { - c = GET(ecode,1); - for (i = 0; i < c; i++) - { - eptr--; - if (eptr < md->start_subject) RRETURN(MATCH_NOMATCH); - BACKCHAR(eptr) - } - } - else -#endif - - /* No UTF-8 support, or not in UTF-8 mode: count is byte count */ - - { - eptr -= GET(ecode,1); - if (eptr < md->start_subject) RRETURN(MATCH_NOMATCH); - } - - /* Skip to next op code */ - - ecode += 1 + LINK_SIZE; - break; - - /* The callout item calls an external function, if one is provided, passing - details of the match so far. This is mainly for debugging, though the - function is able to force a failure. */ - - case OP_CALLOUT: - if (pcre_callout != NULL) - { - pcre_callout_block cb; - cb.version = 1; /* Version 1 of the callout block */ - cb.callout_number = ecode[1]; - cb.offset_vector = md->offset_vector; - cb.subject = (const char *)md->start_subject; - cb.subject_length = md->end_subject - md->start_subject; - cb.start_match = md->start_match - md->start_subject; - cb.current_position = eptr - md->start_subject; - cb.pattern_position = GET(ecode, 2); - cb.next_item_length = GET(ecode, 2 + LINK_SIZE); - cb.capture_top = offset_top/2; - cb.capture_last = md->capture_last; - cb.callout_data = md->callout_data; - if ((rrc = (*pcre_callout)(&cb)) > 0) RRETURN(MATCH_NOMATCH); - if (rrc < 0) RRETURN(rrc); - } - ecode += 2 + 2*LINK_SIZE; - break; - - /* Recursion either matches the current regex, or some subexpression. The - offset data is the offset to the starting bracket from the start of the - whole pattern. (This is so that it works from duplicated subpatterns.) - - If there are any capturing brackets started but not finished, we have to - save their starting points and reinstate them after the recursion. However, - we don't know how many such there are (offset_top records the completed - total) so we just have to save all the potential data. There may be up to - 65535 such values, which is too large to put on the stack, but using malloc - for small numbers seems expensive. As a compromise, the stack is used when - there are no more than REC_STACK_SAVE_MAX values to store; otherwise malloc - is used. A problem is what to do if the malloc fails ... there is no way of - returning to the top level with an error. Save the top REC_STACK_SAVE_MAX - values on the stack, and accept that the rest may be wrong. - - There are also other values that have to be saved. We use a chained - sequence of blocks that actually live on the stack. Thanks to Robin Houston - for the original version of this logic. */ - - case OP_RECURSE: - { - callpat = md->start_code + GET(ecode, 1); - new_recursive.group_num = *callpat - OP_BRA; - - /* For extended extraction brackets (large number), we have to fish out - the number from a dummy opcode at the start. */ - - if (new_recursive.group_num > EXTRACT_BASIC_MAX) - new_recursive.group_num = GET2(callpat, 2+LINK_SIZE); - - /* Add to "recursing stack" */ - - new_recursive.prevrec = md->recursive; - md->recursive = &new_recursive; - - /* Find where to continue from afterwards */ - - ecode += 1 + LINK_SIZE; - new_recursive.after_call = ecode; - - /* Now save the offset data. */ - - new_recursive.saved_max = md->offset_end; - if (new_recursive.saved_max <= REC_STACK_SAVE_MAX) - new_recursive.offset_save = stacksave; - else - { - new_recursive.offset_save = - (int *)(pcre_malloc)(new_recursive.saved_max * sizeof(int)); - if (new_recursive.offset_save == NULL) RRETURN(PCRE_ERROR_NOMEMORY); - } - - memcpy(new_recursive.offset_save, md->offset_vector, - new_recursive.saved_max * sizeof(int)); - new_recursive.save_start = md->start_match; - md->start_match = eptr; - - /* OK, now we can do the recursion. For each top-level alternative we - restore the offset and recursion data. */ - - DPRINTF(("Recursing into group %d\n", new_recursive.group_num)); - do - { - RMATCH(rrc, eptr, callpat + 1 + LINK_SIZE, offset_top, md, ims, - eptrb, match_isgroup); - if (rrc == MATCH_MATCH) - { - md->recursive = new_recursive.prevrec; - if (new_recursive.offset_save != stacksave) - (pcre_free)(new_recursive.offset_save); - RRETURN(MATCH_MATCH); - } - else if (rrc != MATCH_NOMATCH) RRETURN(rrc); - - md->recursive = &new_recursive; - memcpy(md->offset_vector, new_recursive.offset_save, - new_recursive.saved_max * sizeof(int)); - callpat += GET(callpat, 1); - } - while (*callpat == OP_ALT); - - DPRINTF(("Recursion didn't match\n")); - md->recursive = new_recursive.prevrec; - if (new_recursive.offset_save != stacksave) - (pcre_free)(new_recursive.offset_save); - RRETURN(MATCH_NOMATCH); - } - /* Control never reaches here */ - - /* "Once" brackets are like assertion brackets except that after a match, - the point in the subject string is not moved back. Thus there can never be - a move back into the brackets. Friedl calls these "atomic" subpatterns. - Check the alternative branches in turn - the matching won't pass the KET - for this kind of subpattern. If any one branch matches, we carry on as at - the end of a normal bracket, leaving the subject pointer. */ - - case OP_ONCE: - { - prev = ecode; - saved_eptr = eptr; - - do - { - RMATCH(rrc, eptr, ecode + 1 + LINK_SIZE, offset_top, md, ims, - eptrb, match_isgroup); - if (rrc == MATCH_MATCH) break; - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - ecode += GET(ecode,1); - } - while (*ecode == OP_ALT); - - /* If hit the end of the group (which could be repeated), fail */ - - if (*ecode != OP_ONCE && *ecode != OP_ALT) RRETURN(MATCH_NOMATCH); - - /* Continue as from after the assertion, updating the offsets high water - mark, since extracts may have been taken. */ - - do ecode += GET(ecode,1); while (*ecode == OP_ALT); - - offset_top = md->end_offset_top; - eptr = md->end_match_ptr; - - /* For a non-repeating ket, just continue at this level. This also - happens for a repeating ket if no characters were matched in the group. - This is the forcible breaking of infinite loops as implemented in Perl - 5.005. If there is an options reset, it will get obeyed in the normal - course of events. */ - - if (*ecode == OP_KET || eptr == saved_eptr) - { - ecode += 1+LINK_SIZE; - break; - } - - /* The repeating kets try the rest of the pattern or restart from the - preceding bracket, in the appropriate order. We need to reset any options - that changed within the bracket before re-running it, so check the next - opcode. */ - - if (ecode[1+LINK_SIZE] == OP_OPT) - { - ims = (ims & ~PCRE_IMS) | ecode[4]; - DPRINTF(("ims set to %02lx at group repeat\n", ims)); - } - - if (*ecode == OP_KETRMIN) - { - RMATCH(rrc, eptr, ecode + 1 + LINK_SIZE, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - RMATCH(rrc, eptr, prev, offset_top, md, ims, eptrb, match_isgroup); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - } - else /* OP_KETRMAX */ - { - RMATCH(rrc, eptr, prev, offset_top, md, ims, eptrb, match_isgroup); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - RMATCH(rrc, eptr, ecode + 1+LINK_SIZE, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - } - } - RRETURN(MATCH_NOMATCH); - - /* An alternation is the end of a branch; scan along to find the end of the - bracketed group and go to there. */ - - case OP_ALT: - do ecode += GET(ecode,1); while (*ecode == OP_ALT); - break; - - /* BRAZERO and BRAMINZERO occur just before a bracket group, indicating - that it may occur zero times. It may repeat infinitely, or not at all - - i.e. it could be ()* or ()? in the pattern. Brackets with fixed upper - repeat limits are compiled as a number of copies, with the optional ones - preceded by BRAZERO or BRAMINZERO. */ - - case OP_BRAZERO: - { - next = ecode+1; - RMATCH(rrc, eptr, next, offset_top, md, ims, eptrb, match_isgroup); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - do next += GET(next,1); while (*next == OP_ALT); - ecode = next + 1+LINK_SIZE; - } - break; - - case OP_BRAMINZERO: - { - next = ecode+1; - do next += GET(next,1); while (*next == OP_ALT); - RMATCH(rrc, eptr, next + 1+LINK_SIZE, offset_top, md, ims, eptrb, - match_isgroup); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - ecode++; - } - break; - - /* End of a group, repeated or non-repeating. If we are at the end of - an assertion "group", stop matching and return MATCH_MATCH, but record the - current high water mark for use by positive assertions. Do this also - for the "once" (not-backup up) groups. */ - - case OP_KET: - case OP_KETRMIN: - case OP_KETRMAX: - { - prev = ecode - GET(ecode, 1); - saved_eptr = eptrb->epb_saved_eptr; - - /* Back up the stack of bracket start pointers. */ - - eptrb = eptrb->epb_prev; - - if (*prev == OP_ASSERT || *prev == OP_ASSERT_NOT || - *prev == OP_ASSERTBACK || *prev == OP_ASSERTBACK_NOT || - *prev == OP_ONCE) - { - md->end_match_ptr = eptr; /* For ONCE */ - md->end_offset_top = offset_top; - RRETURN(MATCH_MATCH); - } - - /* In all other cases except a conditional group we have to check the - group number back at the start and if necessary complete handling an - extraction by setting the offsets and bumping the high water mark. */ - - if (*prev != OP_COND) - { - number = *prev - OP_BRA; - - /* For extended extraction brackets (large number), we have to fish out - the number from a dummy opcode at the start. */ - - if (number > EXTRACT_BASIC_MAX) number = GET2(prev, 2+LINK_SIZE); - offset = number << 1; - -#ifdef DEBUG - printf("end bracket %d", number); - printf("\n"); -#endif - - /* Test for a numbered group. This includes groups called as a result - of recursion. Note that whole-pattern recursion is coded as a recurse - into group 0, so it won't be picked up here. Instead, we catch it when - the OP_END is reached. */ - - if (number > 0) - { - md->capture_last = number; - if (offset >= md->offset_max) md->offset_overflow = TRUE; else - { - md->offset_vector[offset] = - md->offset_vector[md->offset_end - number]; - md->offset_vector[offset+1] = eptr - md->start_subject; - if (offset_top <= offset) offset_top = offset + 2; - } - - /* Handle a recursively called group. Restore the offsets - appropriately and continue from after the call. */ - - if (md->recursive != NULL && md->recursive->group_num == number) - { - recursion_info *rec = md->recursive; - DPRINTF(("Recursion (%d) succeeded - continuing\n", number)); - md->recursive = rec->prevrec; - md->start_match = rec->save_start; - memcpy(md->offset_vector, rec->offset_save, - rec->saved_max * sizeof(int)); - ecode = rec->after_call; - ims = original_ims; - break; - } - } - } - - /* Reset the value of the ims flags, in case they got changed during - the group. */ - - ims = original_ims; - DPRINTF(("ims reset to %02lx\n", ims)); - - /* For a non-repeating ket, just continue at this level. This also - happens for a repeating ket if no characters were matched in the group. - This is the forcible breaking of infinite loops as implemented in Perl - 5.005. If there is an options reset, it will get obeyed in the normal - course of events. */ - - if (*ecode == OP_KET || eptr == saved_eptr) - { - ecode += 1 + LINK_SIZE; - break; - } - - /* The repeating kets try the rest of the pattern or restart from the - preceding bracket, in the appropriate order. */ - - if (*ecode == OP_KETRMIN) - { - RMATCH(rrc, eptr, ecode + 1+LINK_SIZE, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - RMATCH(rrc, eptr, prev, offset_top, md, ims, eptrb, match_isgroup); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - } - else /* OP_KETRMAX */ - { - RMATCH(rrc, eptr, prev, offset_top, md, ims, eptrb, match_isgroup); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - RMATCH(rrc, eptr, ecode + 1+LINK_SIZE, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - } - } - - RRETURN(MATCH_NOMATCH); - - /* Start of subject unless notbol, or after internal newline if multiline */ - - case OP_CIRC: - if (md->notbol && eptr == md->start_subject) RRETURN(MATCH_NOMATCH); - if ((ims & PCRE_MULTILINE) != 0) - { - if (eptr != md->start_subject && eptr[-1] != NEWLINE) - RRETURN(MATCH_NOMATCH); - ecode++; - break; - } - /* ... else fall through */ - - /* Start of subject assertion */ - - case OP_SOD: - if (eptr != md->start_subject) RRETURN(MATCH_NOMATCH); - ecode++; - break; - - /* Start of match assertion */ - - case OP_SOM: - if (eptr != md->start_subject + md->start_offset) RRETURN(MATCH_NOMATCH); - ecode++; - break; - - /* Assert before internal newline if multiline, or before a terminating - newline unless endonly is set, else end of subject unless noteol is set. */ - - case OP_DOLL: - if ((ims & PCRE_MULTILINE) != 0) - { - if (eptr < md->end_subject) - { if (*eptr != NEWLINE) RRETURN(MATCH_NOMATCH); } - else - { if (md->noteol) RRETURN(MATCH_NOMATCH); } - ecode++; - break; - } - else - { - if (md->noteol) RRETURN(MATCH_NOMATCH); - if (!md->endonly) - { - if (eptr < md->end_subject - 1 || - (eptr == md->end_subject - 1 && *eptr != NEWLINE)) - RRETURN(MATCH_NOMATCH); - ecode++; - break; - } - } - /* ... else fall through */ - - /* End of subject assertion (\z) */ - - case OP_EOD: - if (eptr < md->end_subject) RRETURN(MATCH_NOMATCH); - ecode++; - break; - - /* End of subject or ending \n assertion (\Z) */ - - case OP_EODN: - if (eptr < md->end_subject - 1 || - (eptr == md->end_subject - 1 && *eptr != NEWLINE)) RRETURN(MATCH_NOMATCH); - ecode++; - break; - - /* Word boundary assertions */ - - case OP_NOT_WORD_BOUNDARY: - case OP_WORD_BOUNDARY: - { - - /* Find out if the previous and current characters are "word" characters. - It takes a bit more work in UTF-8 mode. Characters > 255 are assumed to - be "non-word" characters. */ - -#ifdef SUPPORT_UTF8 - if (md->utf8) - { - if (eptr == md->start_subject) prev_is_word = FALSE; else - { - const uschar *lastptr = eptr - 1; - while((*lastptr & 0xc0) == 0x80) lastptr--; - GETCHAR(c, lastptr); - prev_is_word = c < 256 && (md->ctypes[c] & ctype_word) != 0; - } - if (eptr >= md->end_subject) cur_is_word = FALSE; else - { - GETCHAR(c, eptr); - cur_is_word = c < 256 && (md->ctypes[c] & ctype_word) != 0; - } - } - else -#endif - - /* More streamlined when not in UTF-8 mode */ - - { - prev_is_word = (eptr != md->start_subject) && - ((md->ctypes[eptr[-1]] & ctype_word) != 0); - cur_is_word = (eptr < md->end_subject) && - ((md->ctypes[*eptr] & ctype_word) != 0); - } - - /* Now see if the situation is what we want */ - - if ((*ecode++ == OP_WORD_BOUNDARY)? - cur_is_word == prev_is_word : cur_is_word != prev_is_word) - RRETURN(MATCH_NOMATCH); - } - break; - - /* Match a single character type; inline for speed */ - - case OP_ANY: - if ((ims & PCRE_DOTALL) == 0 && eptr < md->end_subject && *eptr == NEWLINE) - RRETURN(MATCH_NOMATCH); - if (eptr++ >= md->end_subject) RRETURN(MATCH_NOMATCH); -#ifdef SUPPORT_UTF8 - if (md->utf8) - while (eptr < md->end_subject && (*eptr & 0xc0) == 0x80) eptr++; -#endif - ecode++; - break; - - /* Match a single byte, even in UTF-8 mode. This opcode really does match - any byte, even newline, independent of the setting of PCRE_DOTALL. */ - - case OP_ANYBYTE: - if (eptr++ >= md->end_subject) RRETURN(MATCH_NOMATCH); - ecode++; - break; - - case OP_NOT_DIGIT: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - if ( -#ifdef SUPPORT_UTF8 - c < 256 && -#endif - (md->ctypes[c] & ctype_digit) != 0 - ) - RRETURN(MATCH_NOMATCH); - ecode++; - break; - - case OP_DIGIT: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - if ( -#ifdef SUPPORT_UTF8 - c >= 256 || -#endif - (md->ctypes[c] & ctype_digit) == 0 - ) - RRETURN(MATCH_NOMATCH); - ecode++; - break; - - case OP_NOT_WHITESPACE: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - if ( -#ifdef SUPPORT_UTF8 - c < 256 && -#endif - (md->ctypes[c] & ctype_space) != 0 - ) - RRETURN(MATCH_NOMATCH); - ecode++; - break; - - case OP_WHITESPACE: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - if ( -#ifdef SUPPORT_UTF8 - c >= 256 || -#endif - (md->ctypes[c] & ctype_space) == 0 - ) - RRETURN(MATCH_NOMATCH); - ecode++; - break; - - case OP_NOT_WORDCHAR: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - if ( -#ifdef SUPPORT_UTF8 - c < 256 && -#endif - (md->ctypes[c] & ctype_word) != 0 - ) - RRETURN(MATCH_NOMATCH); - ecode++; - break; - - case OP_WORDCHAR: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - if ( -#ifdef SUPPORT_UTF8 - c >= 256 || -#endif - (md->ctypes[c] & ctype_word) == 0 - ) - RRETURN(MATCH_NOMATCH); - ecode++; - break; - -#ifdef SUPPORT_UCP - /* Check the next character by Unicode property. We will get here only - if the support is in the binary; otherwise a compile-time error occurs. */ - - case OP_PROP: - case OP_NOTPROP: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - { - int chartype, rqdtype; - int othercase; - int category = ucp_findchar(c, &chartype, &othercase); - - rqdtype = *(++ecode); - ecode++; - - if (rqdtype >= 128) - { - if ((rqdtype - 128 != category) == (op == OP_PROP)) - RRETURN(MATCH_NOMATCH); - } - else - { - if ((rqdtype != chartype) == (op == OP_PROP)) - RRETURN(MATCH_NOMATCH); - } - } - break; - - /* Match an extended Unicode sequence. We will get here only if the support - is in the binary; otherwise a compile-time error occurs. */ - - case OP_EXTUNI: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - { - int chartype; - int othercase; - int category = ucp_findchar(c, &chartype, &othercase); - if (category == ucp_M) RRETURN(MATCH_NOMATCH); - while (eptr < md->end_subject) - { - int len = 1; - if (!md->utf8) c = *eptr; else - { - GETCHARLEN(c, eptr, len); - } - category = ucp_findchar(c, &chartype, &othercase); - if (category != ucp_M) break; - eptr += len; - } - } - ecode++; - break; -#endif - - - /* Match a back reference, possibly repeatedly. Look past the end of the - item to see if there is repeat information following. The code is similar - to that for character classes, but repeated for efficiency. Then obey - similar code to character type repeats - written out again for speed. - However, if the referenced string is the empty string, always treat - it as matched, any number of times (otherwise there could be infinite - loops). */ - - case OP_REF: - { - offset = GET2(ecode, 1) << 1; /* Doubled ref number */ - ecode += 3; /* Advance past item */ - - /* If the reference is unset, set the length to be longer than the amount - of subject left; this ensures that every attempt at a match fails. We - can't just fail here, because of the possibility of quantifiers with zero - minima. */ - - length = (offset >= offset_top || md->offset_vector[offset] < 0)? - md->end_subject - eptr + 1 : - md->offset_vector[offset+1] - md->offset_vector[offset]; - - /* Set up for repetition, or handle the non-repeated case */ - - switch (*ecode) - { - case OP_CRSTAR: - case OP_CRMINSTAR: - case OP_CRPLUS: - case OP_CRMINPLUS: - case OP_CRQUERY: - case OP_CRMINQUERY: - c = *ecode++ - OP_CRSTAR; - minimize = (c & 1) != 0; - min = rep_min[c]; /* Pick up values from tables; */ - max = rep_max[c]; /* zero for max => infinity */ - if (max == 0) max = INT_MAX; - break; - - case OP_CRRANGE: - case OP_CRMINRANGE: - minimize = (*ecode == OP_CRMINRANGE); - min = GET2(ecode, 1); - max = GET2(ecode, 3); - if (max == 0) max = INT_MAX; - ecode += 5; - break; - - default: /* No repeat follows */ - if (!match_ref(offset, eptr, length, md, ims)) RRETURN(MATCH_NOMATCH); - eptr += length; - continue; /* With the main loop */ - } - - /* If the length of the reference is zero, just continue with the - main loop. */ - - if (length == 0) continue; - - /* First, ensure the minimum number of matches are present. We get back - the length of the reference string explicitly rather than passing the - address of eptr, so that eptr can be a register variable. */ - - for (i = 1; i <= min; i++) - { - if (!match_ref(offset, eptr, length, md, ims)) RRETURN(MATCH_NOMATCH); - eptr += length; - } - - /* If min = max, continue at the same level without recursion. - They are not both allowed to be zero. */ - - if (min == max) continue; - - /* If minimizing, keep trying and advancing the pointer */ - - if (minimize) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || !match_ref(offset, eptr, length, md, ims)) - RRETURN(MATCH_NOMATCH); - eptr += length; - } - /* Control never gets here */ - } - - /* If maximizing, find the longest string and work backwards */ - - else - { - pp = eptr; - for (i = min; i < max; i++) - { - if (!match_ref(offset, eptr, length, md, ims)) break; - eptr += length; - } - while (eptr >= pp) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - eptr -= length; - } - RRETURN(MATCH_NOMATCH); - } - } - /* Control never gets here */ - - - - /* Match a bit-mapped character class, possibly repeatedly. This op code is - used when all the characters in the class have values in the range 0-255, - and either the matching is caseful, or the characters are in the range - 0-127 when UTF-8 processing is enabled. The only difference between - OP_CLASS and OP_NCLASS occurs when a data character outside the range is - encountered. - - First, look past the end of the item to see if there is repeat information - following. Then obey similar code to character type repeats - written out - again for speed. */ - - case OP_NCLASS: - case OP_CLASS: - { - data = ecode + 1; /* Save for matching */ - ecode += 33; /* Advance past the item */ - - switch (*ecode) - { - case OP_CRSTAR: - case OP_CRMINSTAR: - case OP_CRPLUS: - case OP_CRMINPLUS: - case OP_CRQUERY: - case OP_CRMINQUERY: - c = *ecode++ - OP_CRSTAR; - minimize = (c & 1) != 0; - min = rep_min[c]; /* Pick up values from tables; */ - max = rep_max[c]; /* zero for max => infinity */ - if (max == 0) max = INT_MAX; - break; - - case OP_CRRANGE: - case OP_CRMINRANGE: - minimize = (*ecode == OP_CRMINRANGE); - min = GET2(ecode, 1); - max = GET2(ecode, 3); - if (max == 0) max = INT_MAX; - ecode += 5; - break; - - default: /* No repeat follows */ - min = max = 1; - break; - } - - /* First, ensure the minimum number of matches are present. */ - -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINC(c, eptr); - if (c > 255) - { - if (op == OP_CLASS) RRETURN(MATCH_NOMATCH); - } - else - { - if ((data[c/8] & (1 << (c&7))) == 0) RRETURN(MATCH_NOMATCH); - } - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - c = *eptr++; - if ((data[c/8] & (1 << (c&7))) == 0) RRETURN(MATCH_NOMATCH); - } - } - - /* If max == min we can continue with the main loop without the - need to recurse. */ - - if (min == max) continue; - - /* If minimizing, keep testing the rest of the expression and advancing - the pointer while it matches the class. */ - - if (minimize) - { -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINC(c, eptr); - if (c > 255) - { - if (op == OP_CLASS) RRETURN(MATCH_NOMATCH); - } - else - { - if ((data[c/8] & (1 << (c&7))) == 0) RRETURN(MATCH_NOMATCH); - } - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - c = *eptr++; - if ((data[c/8] & (1 << (c&7))) == 0) RRETURN(MATCH_NOMATCH); - } - } - /* Control never gets here */ - } - - /* If maximizing, find the longest possible run, then work backwards. */ - - else - { - pp = eptr; - -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - if (c > 255) - { - if (op == OP_CLASS) break; - } - else - { - if ((data[c/8] & (1 << (c&7))) == 0) break; - } - eptr += len; - } - for (;;) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (eptr-- == pp) break; /* Stop if tried at original pos */ - BACKCHAR(eptr); - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject) break; - c = *eptr; - if ((data[c/8] & (1 << (c&7))) == 0) break; - eptr++; - } - while (eptr >= pp) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - eptr--; - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - } - } - - RRETURN(MATCH_NOMATCH); - } - } - /* Control never gets here */ - - - /* Match an extended character class. This opcode is encountered only - in UTF-8 mode, because that's the only time it is compiled. */ - -#ifdef SUPPORT_UTF8 - case OP_XCLASS: - { - data = ecode + 1 + LINK_SIZE; /* Save for matching */ - ecode += GET(ecode, 1); /* Advance past the item */ - - switch (*ecode) - { - case OP_CRSTAR: - case OP_CRMINSTAR: - case OP_CRPLUS: - case OP_CRMINPLUS: - case OP_CRQUERY: - case OP_CRMINQUERY: - c = *ecode++ - OP_CRSTAR; - minimize = (c & 1) != 0; - min = rep_min[c]; /* Pick up values from tables; */ - max = rep_max[c]; /* zero for max => infinity */ - if (max == 0) max = INT_MAX; - break; - - case OP_CRRANGE: - case OP_CRMINRANGE: - minimize = (*ecode == OP_CRMINRANGE); - min = GET2(ecode, 1); - max = GET2(ecode, 3); - if (max == 0) max = INT_MAX; - ecode += 5; - break; - - default: /* No repeat follows */ - min = max = 1; - break; - } - - /* First, ensure the minimum number of matches are present. */ - - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINC(c, eptr); - if (!match_xclass(c, data)) RRETURN(MATCH_NOMATCH); - } - - /* If max == min we can continue with the main loop without the - need to recurse. */ - - if (min == max) continue; - - /* If minimizing, keep testing the rest of the expression and advancing - the pointer while it matches the class. */ - - if (minimize) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINC(c, eptr); - if (!match_xclass(c, data)) RRETURN(MATCH_NOMATCH); - } - /* Control never gets here */ - } - - /* If maximizing, find the longest possible run, then work backwards. */ - - else - { - pp = eptr; - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - if (!match_xclass(c, data)) break; - eptr += len; - } - for(;;) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (eptr-- == pp) break; /* Stop if tried at original pos */ - BACKCHAR(eptr) - } - RRETURN(MATCH_NOMATCH); - } - - /* Control never gets here */ - } -#endif /* End of XCLASS */ - - /* Match a single character, casefully */ - - case OP_CHAR: -#ifdef SUPPORT_UTF8 - if (md->utf8) - { - length = 1; - ecode++; - GETCHARLEN(fc, ecode, length); - if (length > md->end_subject - eptr) RRETURN(MATCH_NOMATCH); - while (length-- > 0) if (*ecode++ != *eptr++) RRETURN(MATCH_NOMATCH); - } - else -#endif - - /* Non-UTF-8 mode */ - { - if (md->end_subject - eptr < 1) RRETURN(MATCH_NOMATCH); - if (ecode[1] != *eptr++) RRETURN(MATCH_NOMATCH); - ecode += 2; - } - break; - - /* Match a single character, caselessly */ - - case OP_CHARNC: -#ifdef SUPPORT_UTF8 - if (md->utf8) - { - length = 1; - ecode++; - GETCHARLEN(fc, ecode, length); - - if (length > md->end_subject - eptr) RRETURN(MATCH_NOMATCH); - - /* If the pattern character's value is < 128, we have only one byte, and - can use the fast lookup table. */ - - if (fc < 128) - { - if (md->lcc[*ecode++] != md->lcc[*eptr++]) RRETURN(MATCH_NOMATCH); - } - - /* Otherwise we must pick up the subject character */ - - else - { - int dc; - GETCHARINC(dc, eptr); - ecode += length; - - /* If we have Unicode property support, we can use it to test the other - case of the character, if there is one. The result of ucp_findchar() is - < 0 if the char isn't found, and othercase is returned as zero if there - isn't one. */ - - if (fc != dc) - { -#ifdef SUPPORT_UCP - int chartype; - int othercase; - if (ucp_findchar(fc, &chartype, &othercase) < 0 || dc != othercase) -#endif - RRETURN(MATCH_NOMATCH); - } - } - } - else -#endif /* SUPPORT_UTF8 */ - - /* Non-UTF-8 mode */ - { - if (md->end_subject - eptr < 1) RRETURN(MATCH_NOMATCH); - if (md->lcc[ecode[1]] != md->lcc[*eptr++]) RRETURN(MATCH_NOMATCH); - ecode += 2; - } - break; - - /* Match a single character repeatedly; different opcodes share code. */ - - case OP_EXACT: - min = max = GET2(ecode, 1); - ecode += 3; - goto REPEATCHAR; - - case OP_UPTO: - case OP_MINUPTO: - min = 0; - max = GET2(ecode, 1); - minimize = *ecode == OP_MINUPTO; - ecode += 3; - goto REPEATCHAR; - - case OP_STAR: - case OP_MINSTAR: - case OP_PLUS: - case OP_MINPLUS: - case OP_QUERY: - case OP_MINQUERY: - c = *ecode++ - OP_STAR; - minimize = (c & 1) != 0; - min = rep_min[c]; /* Pick up values from tables; */ - max = rep_max[c]; /* zero for max => infinity */ - if (max == 0) max = INT_MAX; - - /* Common code for all repeated single-character matches. We can give - up quickly if there are fewer than the minimum number of characters left in - the subject. */ - - REPEATCHAR: -#ifdef SUPPORT_UTF8 - if (md->utf8) - { - length = 1; - charptr = ecode; - GETCHARLEN(fc, ecode, length); - if (min * length > md->end_subject - eptr) RRETURN(MATCH_NOMATCH); - ecode += length; - - /* Handle multibyte character matching specially here. There is - support for caseless matching if UCP support is present. */ - - if (length > 1) - { - int oclength = 0; - uschar occhars[8]; - -#ifdef SUPPORT_UCP - int othercase; - int chartype; - if ((ims & PCRE_CASELESS) != 0 && - ucp_findchar(fc, &chartype, &othercase) >= 0 && - othercase > 0) - oclength = ord2utf8(othercase, occhars); -#endif /* SUPPORT_UCP */ - - for (i = 1; i <= min; i++) - { - if (memcmp(eptr, charptr, length) == 0) eptr += length; - /* Need braces because of following else */ - else if (oclength == 0) { RRETURN(MATCH_NOMATCH); } - else - { - if (memcmp(eptr, occhars, oclength) != 0) RRETURN(MATCH_NOMATCH); - eptr += oclength; - } - } - - if (min == max) continue; - - if (minimize) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - if (memcmp(eptr, charptr, length) == 0) eptr += length; - /* Need braces because of following else */ - else if (oclength == 0) { RRETURN(MATCH_NOMATCH); } - else - { - if (memcmp(eptr, occhars, oclength) != 0) RRETURN(MATCH_NOMATCH); - eptr += oclength; - } - } - /* Control never gets here */ - } - else - { - pp = eptr; - for (i = min; i < max; i++) - { - if (eptr > md->end_subject - length) break; - if (memcmp(eptr, charptr, length) == 0) eptr += length; - else if (oclength == 0) break; - else - { - if (memcmp(eptr, occhars, oclength) != 0) break; - eptr += oclength; - } - } - while (eptr >= pp) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - eptr -= length; - } - RRETURN(MATCH_NOMATCH); - } - /* Control never gets here */ - } - - /* If the length of a UTF-8 character is 1, we fall through here, and - obey the code as for non-UTF-8 characters below, though in this case the - value of fc will always be < 128. */ - } - else -#endif /* SUPPORT_UTF8 */ - - /* When not in UTF-8 mode, load a single-byte character. */ - { - if (min > md->end_subject - eptr) RRETURN(MATCH_NOMATCH); - fc = *ecode++; - } - - /* The value of fc at this point is always less than 256, though we may or - may not be in UTF-8 mode. The code is duplicated for the caseless and - caseful cases, for speed, since matching characters is likely to be quite - common. First, ensure the minimum number of matches are present. If min = - max, continue at the same level without recursing. Otherwise, if - minimizing, keep trying the rest of the expression and advancing one - matching character if failing, up to the maximum. Alternatively, if - maximizing, find the maximum number of characters and work backwards. */ - - DPRINTF(("matching %c{%d,%d} against subject %.*s\n", fc, min, max, - max, eptr)); - - if ((ims & PCRE_CASELESS) != 0) - { - fc = md->lcc[fc]; - for (i = 1; i <= min; i++) - if (fc != md->lcc[*eptr++]) RRETURN(MATCH_NOMATCH); - if (min == max) continue; - if (minimize) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject || - fc != md->lcc[*eptr++]) - RRETURN(MATCH_NOMATCH); - } - /* Control never gets here */ - } - else - { - pp = eptr; - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || fc != md->lcc[*eptr]) break; - eptr++; - } - while (eptr >= pp) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - eptr--; - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - } - RRETURN(MATCH_NOMATCH); - } - /* Control never gets here */ - } - - /* Caseful comparisons (includes all multi-byte characters) */ - - else - { - for (i = 1; i <= min; i++) if (fc != *eptr++) RRETURN(MATCH_NOMATCH); - if (min == max) continue; - if (minimize) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject || fc != *eptr++) - RRETURN(MATCH_NOMATCH); - } - /* Control never gets here */ - } - else - { - pp = eptr; - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || fc != *eptr) break; - eptr++; - } - while (eptr >= pp) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - eptr--; - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - } - RRETURN(MATCH_NOMATCH); - } - } - /* Control never gets here */ - - /* Match a negated single one-byte character. The character we are - checking can be multibyte. */ - - case OP_NOT: - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - ecode++; - GETCHARINCTEST(c, eptr); - if ((ims & PCRE_CASELESS) != 0) - { -#ifdef SUPPORT_UTF8 - if (c < 256) -#endif - c = md->lcc[c]; - if (md->lcc[*ecode++] == c) RRETURN(MATCH_NOMATCH); - } - else - { - if (*ecode++ == c) RRETURN(MATCH_NOMATCH); - } - break; - - /* Match a negated single one-byte character repeatedly. This is almost a - repeat of the code for a repeated single character, but I haven't found a - nice way of commoning these up that doesn't require a test of the - positive/negative option for each character match. Maybe that wouldn't add - very much to the time taken, but character matching *is* what this is all - about... */ - - case OP_NOTEXACT: - min = max = GET2(ecode, 1); - ecode += 3; - goto REPEATNOTCHAR; - - case OP_NOTUPTO: - case OP_NOTMINUPTO: - min = 0; - max = GET2(ecode, 1); - minimize = *ecode == OP_NOTMINUPTO; - ecode += 3; - goto REPEATNOTCHAR; - - case OP_NOTSTAR: - case OP_NOTMINSTAR: - case OP_NOTPLUS: - case OP_NOTMINPLUS: - case OP_NOTQUERY: - case OP_NOTMINQUERY: - c = *ecode++ - OP_NOTSTAR; - minimize = (c & 1) != 0; - min = rep_min[c]; /* Pick up values from tables; */ - max = rep_max[c]; /* zero for max => infinity */ - if (max == 0) max = INT_MAX; - - /* Common code for all repeated single-byte matches. We can give up quickly - if there are fewer than the minimum number of bytes left in the - subject. */ - - REPEATNOTCHAR: - if (min > md->end_subject - eptr) RRETURN(MATCH_NOMATCH); - fc = *ecode++; - - /* The code is duplicated for the caseless and caseful cases, for speed, - since matching characters is likely to be quite common. First, ensure the - minimum number of matches are present. If min = max, continue at the same - level without recursing. Otherwise, if minimizing, keep trying the rest of - the expression and advancing one matching character if failing, up to the - maximum. Alternatively, if maximizing, find the maximum number of - characters and work backwards. */ - - DPRINTF(("negative matching %c{%d,%d} against subject %.*s\n", fc, min, max, - max, eptr)); - - if ((ims & PCRE_CASELESS) != 0) - { - fc = md->lcc[fc]; - -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - register int d; - for (i = 1; i <= min; i++) - { - GETCHARINC(d, eptr); - if (d < 256) d = md->lcc[d]; - if (fc == d) RRETURN(MATCH_NOMATCH); - } - } - else -#endif - - /* Not UTF-8 mode */ - { - for (i = 1; i <= min; i++) - if (fc == md->lcc[*eptr++]) RRETURN(MATCH_NOMATCH); - } - - if (min == max) continue; - - if (minimize) - { -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - register int d; - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - GETCHARINC(d, eptr); - if (d < 256) d = md->lcc[d]; - if (fi >= max || eptr >= md->end_subject || fc == d) - RRETURN(MATCH_NOMATCH); - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject || fc == md->lcc[*eptr++]) - RRETURN(MATCH_NOMATCH); - } - } - /* Control never gets here */ - } - - /* Maximize case */ - - else - { - pp = eptr; - -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - register int d; - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(d, eptr, len); - if (d < 256) d = md->lcc[d]; - if (fc == d) break; - eptr += len; - } - for(;;) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (eptr-- == pp) break; /* Stop if tried at original pos */ - BACKCHAR(eptr); - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || fc == md->lcc[*eptr]) break; - eptr++; - } - while (eptr >= pp) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - eptr--; - } - } - - RRETURN(MATCH_NOMATCH); - } - /* Control never gets here */ - } - - /* Caseful comparisons */ - - else - { -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - register int d; - for (i = 1; i <= min; i++) - { - GETCHARINC(d, eptr); - if (fc == d) RRETURN(MATCH_NOMATCH); - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (i = 1; i <= min; i++) - if (fc == *eptr++) RRETURN(MATCH_NOMATCH); - } - - if (min == max) continue; - - if (minimize) - { -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - register int d; - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - GETCHARINC(d, eptr); - if (fi >= max || eptr >= md->end_subject || fc == d) - RRETURN(MATCH_NOMATCH); - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject || fc == *eptr++) - RRETURN(MATCH_NOMATCH); - } - } - /* Control never gets here */ - } - - /* Maximize case */ - - else - { - pp = eptr; - -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - register int d; - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(d, eptr, len); - if (fc == d) break; - eptr += len; - } - for(;;) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (eptr-- == pp) break; /* Stop if tried at original pos */ - BACKCHAR(eptr); - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || fc == *eptr) break; - eptr++; - } - while (eptr >= pp) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - eptr--; - } - } - - RRETURN(MATCH_NOMATCH); - } - } - /* Control never gets here */ - - /* Match a single character type repeatedly; several different opcodes - share code. This is very similar to the code for single characters, but we - repeat it in the interests of efficiency. */ - - case OP_TYPEEXACT: - min = max = GET2(ecode, 1); - minimize = TRUE; - ecode += 3; - goto REPEATTYPE; - - case OP_TYPEUPTO: - case OP_TYPEMINUPTO: - min = 0; - max = GET2(ecode, 1); - minimize = *ecode == OP_TYPEMINUPTO; - ecode += 3; - goto REPEATTYPE; - - case OP_TYPESTAR: - case OP_TYPEMINSTAR: - case OP_TYPEPLUS: - case OP_TYPEMINPLUS: - case OP_TYPEQUERY: - case OP_TYPEMINQUERY: - c = *ecode++ - OP_TYPESTAR; - minimize = (c & 1) != 0; - min = rep_min[c]; /* Pick up values from tables; */ - max = rep_max[c]; /* zero for max => infinity */ - if (max == 0) max = INT_MAX; - - /* Common code for all repeated single character type matches. Note that - in UTF-8 mode, '.' matches a character of any length, but for the other - character types, the valid characters are all one-byte long. */ - - REPEATTYPE: - ctype = *ecode++; /* Code for the character type */ - -#ifdef SUPPORT_UCP - if (ctype == OP_PROP || ctype == OP_NOTPROP) - { - prop_fail_result = ctype == OP_NOTPROP; - prop_type = *ecode++; - if (prop_type >= 128) - { - prop_test_against = prop_type - 128; - prop_test_variable = &prop_category; - } - else - { - prop_test_against = prop_type; - prop_test_variable = &prop_chartype; - } - } - else prop_type = -1; -#endif - - /* First, ensure the minimum number of matches are present. Use inline - code for maximizing the speed, and do the type test once at the start - (i.e. keep it out of the loop). Also we can test that there are at least - the minimum number of bytes before we start. This isn't as effective in - UTF-8 mode, but it does no harm. Separate the UTF-8 code completely as that - is tidier. Also separate the UCP code, which can be the same for both UTF-8 - and single-bytes. */ - - if (min > md->end_subject - eptr) RRETURN(MATCH_NOMATCH); - if (min > 0) - { -#ifdef SUPPORT_UCP - if (prop_type > 0) - { - for (i = 1; i <= min; i++) - { - GETCHARINC(c, eptr); - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if ((*prop_test_variable == prop_test_against) == prop_fail_result) - RRETURN(MATCH_NOMATCH); - } - } - - /* Match extended Unicode sequences. We will get here only if the - support is in the binary; otherwise a compile-time error occurs. */ - - else if (ctype == OP_EXTUNI) - { - for (i = 1; i <= min; i++) - { - GETCHARINCTEST(c, eptr); - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if (prop_category == ucp_M) RRETURN(MATCH_NOMATCH); - while (eptr < md->end_subject) - { - int len = 1; - if (!md->utf8) c = *eptr; else - { - GETCHARLEN(c, eptr, len); - } - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if (prop_category != ucp_M) break; - eptr += len; - } - } - } - - else -#endif /* SUPPORT_UCP */ - -/* Handle all other cases when the coding is UTF-8 */ - -#ifdef SUPPORT_UTF8 - if (md->utf8) switch(ctype) - { - case OP_ANY: - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject || - (*eptr++ == NEWLINE && (ims & PCRE_DOTALL) == 0)) - RRETURN(MATCH_NOMATCH); - while (eptr < md->end_subject && (*eptr & 0xc0) == 0x80) eptr++; - } - break; - - case OP_ANYBYTE: - eptr += min; - break; - - case OP_NOT_DIGIT: - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINC(c, eptr); - if (c < 128 && (md->ctypes[c] & ctype_digit) != 0) - RRETURN(MATCH_NOMATCH); - } - break; - - case OP_DIGIT: - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject || - *eptr >= 128 || (md->ctypes[*eptr++] & ctype_digit) == 0) - RRETURN(MATCH_NOMATCH); - /* No need to skip more bytes - we know it's a 1-byte character */ - } - break; - - case OP_NOT_WHITESPACE: - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject || - (*eptr < 128 && (md->ctypes[*eptr++] & ctype_space) != 0)) - RRETURN(MATCH_NOMATCH); - while (eptr < md->end_subject && (*eptr & 0xc0) == 0x80) eptr++; - } - break; - - case OP_WHITESPACE: - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject || - *eptr >= 128 || (md->ctypes[*eptr++] & ctype_space) == 0) - RRETURN(MATCH_NOMATCH); - /* No need to skip more bytes - we know it's a 1-byte character */ - } - break; - - case OP_NOT_WORDCHAR: - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject || - (*eptr < 128 && (md->ctypes[*eptr++] & ctype_word) != 0)) - RRETURN(MATCH_NOMATCH); - while (eptr < md->end_subject && (*eptr & 0xc0) == 0x80) eptr++; - } - break; - - case OP_WORDCHAR: - for (i = 1; i <= min; i++) - { - if (eptr >= md->end_subject || - *eptr >= 128 || (md->ctypes[*eptr++] & ctype_word) == 0) - RRETURN(MATCH_NOMATCH); - /* No need to skip more bytes - we know it's a 1-byte character */ - } - break; - - default: - RRETURN(PCRE_ERROR_INTERNAL); - } /* End switch(ctype) */ - - else -#endif /* SUPPORT_UTF8 */ - - /* Code for the non-UTF-8 case for minimum matching of operators other - than OP_PROP and OP_NOTPROP. */ - - switch(ctype) - { - case OP_ANY: - if ((ims & PCRE_DOTALL) == 0) - { - for (i = 1; i <= min; i++) - if (*eptr++ == NEWLINE) RRETURN(MATCH_NOMATCH); - } - else eptr += min; - break; - - case OP_ANYBYTE: - eptr += min; - break; - - case OP_NOT_DIGIT: - for (i = 1; i <= min; i++) - if ((md->ctypes[*eptr++] & ctype_digit) != 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_DIGIT: - for (i = 1; i <= min; i++) - if ((md->ctypes[*eptr++] & ctype_digit) == 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_NOT_WHITESPACE: - for (i = 1; i <= min; i++) - if ((md->ctypes[*eptr++] & ctype_space) != 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_WHITESPACE: - for (i = 1; i <= min; i++) - if ((md->ctypes[*eptr++] & ctype_space) == 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_NOT_WORDCHAR: - for (i = 1; i <= min; i++) - if ((md->ctypes[*eptr++] & ctype_word) != 0) - RRETURN(MATCH_NOMATCH); - break; - - case OP_WORDCHAR: - for (i = 1; i <= min; i++) - if ((md->ctypes[*eptr++] & ctype_word) == 0) - RRETURN(MATCH_NOMATCH); - break; - - default: - RRETURN(PCRE_ERROR_INTERNAL); - } - } - - /* If min = max, continue at the same level without recursing */ - - if (min == max) continue; - - /* If minimizing, we have to test the rest of the pattern before each - subsequent match. Again, separate the UTF-8 case for speed, and also - separate the UCP cases. */ - - if (minimize) - { -#ifdef SUPPORT_UCP - if (prop_type > 0) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINC(c, eptr); - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if ((*prop_test_variable == prop_test_against) == prop_fail_result) - RRETURN(MATCH_NOMATCH); - } - } - - /* Match extended Unicode sequences. We will get here only if the - support is in the binary; otherwise a compile-time error occurs. */ - - else if (ctype == OP_EXTUNI) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - GETCHARINCTEST(c, eptr); - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if (prop_category == ucp_M) RRETURN(MATCH_NOMATCH); - while (eptr < md->end_subject) - { - int len = 1; - if (!md->utf8) c = *eptr; else - { - GETCHARLEN(c, eptr, len); - } - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if (prop_category != ucp_M) break; - eptr += len; - } - } - } - - else -#endif /* SUPPORT_UCP */ - -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - if (md->utf8) - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - - GETCHARINC(c, eptr); - switch(ctype) - { - case OP_ANY: - if ((ims & PCRE_DOTALL) == 0 && c == NEWLINE) RRETURN(MATCH_NOMATCH); - break; - - case OP_ANYBYTE: - break; - - case OP_NOT_DIGIT: - if (c < 256 && (md->ctypes[c] & ctype_digit) != 0) - RRETURN(MATCH_NOMATCH); - break; - - case OP_DIGIT: - if (c >= 256 || (md->ctypes[c] & ctype_digit) == 0) - RRETURN(MATCH_NOMATCH); - break; - - case OP_NOT_WHITESPACE: - if (c < 256 && (md->ctypes[c] & ctype_space) != 0) - RRETURN(MATCH_NOMATCH); - break; - - case OP_WHITESPACE: - if (c >= 256 || (md->ctypes[c] & ctype_space) == 0) - RRETURN(MATCH_NOMATCH); - break; - - case OP_NOT_WORDCHAR: - if (c < 256 && (md->ctypes[c] & ctype_word) != 0) - RRETURN(MATCH_NOMATCH); - break; - - case OP_WORDCHAR: - if (c >= 256 && (md->ctypes[c] & ctype_word) == 0) - RRETURN(MATCH_NOMATCH); - break; - - default: - RRETURN(PCRE_ERROR_INTERNAL); - } - } - } - else -#endif - /* Not UTF-8 mode */ - { - for (fi = min;; fi++) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (fi >= max || eptr >= md->end_subject) RRETURN(MATCH_NOMATCH); - c = *eptr++; - switch(ctype) - { - case OP_ANY: - if ((ims & PCRE_DOTALL) == 0 && c == NEWLINE) RRETURN(MATCH_NOMATCH); - break; - - case OP_ANYBYTE: - break; - - case OP_NOT_DIGIT: - if ((md->ctypes[c] & ctype_digit) != 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_DIGIT: - if ((md->ctypes[c] & ctype_digit) == 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_NOT_WHITESPACE: - if ((md->ctypes[c] & ctype_space) != 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_WHITESPACE: - if ((md->ctypes[c] & ctype_space) == 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_NOT_WORDCHAR: - if ((md->ctypes[c] & ctype_word) != 0) RRETURN(MATCH_NOMATCH); - break; - - case OP_WORDCHAR: - if ((md->ctypes[c] & ctype_word) == 0) RRETURN(MATCH_NOMATCH); - break; - - default: - RRETURN(PCRE_ERROR_INTERNAL); - } - } - } - /* Control never gets here */ - } - - /* If maximizing it is worth using inline code for speed, doing the type - test once at the start (i.e. keep it out of the loop). Again, keep the - UTF-8 and UCP stuff separate. */ - - else - { - pp = eptr; /* Remember where we started */ - -#ifdef SUPPORT_UCP - if (prop_type > 0) - { - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if ((*prop_test_variable == prop_test_against) == prop_fail_result) - break; - eptr+= len; - } - - /* eptr is now past the end of the maximum run */ - - for(;;) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (eptr-- == pp) break; /* Stop if tried at original pos */ - BACKCHAR(eptr); - } - } - - /* Match extended Unicode sequences. We will get here only if the - support is in the binary; otherwise a compile-time error occurs. */ - - else if (ctype == OP_EXTUNI) - { - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject) break; - GETCHARINCTEST(c, eptr); - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if (prop_category == ucp_M) break; - while (eptr < md->end_subject) - { - int len = 1; - if (!md->utf8) c = *eptr; else - { - GETCHARLEN(c, eptr, len); - } - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if (prop_category != ucp_M) break; - eptr += len; - } - } - - /* eptr is now past the end of the maximum run */ - - for(;;) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (eptr-- == pp) break; /* Stop if tried at original pos */ - for (;;) /* Move back over one extended */ - { - int len = 1; - BACKCHAR(eptr); - if (!md->utf8) c = *eptr; else - { - GETCHARLEN(c, eptr, len); - } - prop_category = ucp_findchar(c, &prop_chartype, &prop_othercase); - if (prop_category != ucp_M) break; - eptr--; - } - } - } - - else -#endif /* SUPPORT_UCP */ - -#ifdef SUPPORT_UTF8 - /* UTF-8 mode */ - - if (md->utf8) - { - switch(ctype) - { - case OP_ANY: - - /* Special code is required for UTF8, but when the maximum is unlimited - we don't need it, so we repeat the non-UTF8 code. This is probably - worth it, because .* is quite a common idiom. */ - - if (max < INT_MAX) - { - if ((ims & PCRE_DOTALL) == 0) - { - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || *eptr == NEWLINE) break; - eptr++; - while (eptr < md->end_subject && (*eptr & 0xc0) == 0x80) eptr++; - } - } - else - { - for (i = min; i < max; i++) - { - eptr++; - while (eptr < md->end_subject && (*eptr & 0xc0) == 0x80) eptr++; - } - } - } - - /* Handle unlimited UTF-8 repeat */ - - else - { - if ((ims & PCRE_DOTALL) == 0) - { - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || *eptr == NEWLINE) break; - eptr++; - } - break; - } - else - { - c = max - min; - if (c > md->end_subject - eptr) c = md->end_subject - eptr; - eptr += c; - } - } - break; - - /* The byte case is the same as non-UTF8 */ - - case OP_ANYBYTE: - c = max - min; - if (c > md->end_subject - eptr) c = md->end_subject - eptr; - eptr += c; - break; - - case OP_NOT_DIGIT: - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - if (c < 256 && (md->ctypes[c] & ctype_digit) != 0) break; - eptr+= len; - } - break; - - case OP_DIGIT: - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - if (c >= 256 ||(md->ctypes[c] & ctype_digit) == 0) break; - eptr+= len; - } - break; - - case OP_NOT_WHITESPACE: - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - if (c < 256 && (md->ctypes[c] & ctype_space) != 0) break; - eptr+= len; - } - break; - - case OP_WHITESPACE: - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - if (c >= 256 ||(md->ctypes[c] & ctype_space) == 0) break; - eptr+= len; - } - break; - - case OP_NOT_WORDCHAR: - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - if (c < 256 && (md->ctypes[c] & ctype_word) != 0) break; - eptr+= len; - } - break; - - case OP_WORDCHAR: - for (i = min; i < max; i++) - { - int len = 1; - if (eptr >= md->end_subject) break; - GETCHARLEN(c, eptr, len); - if (c >= 256 || (md->ctypes[c] & ctype_word) == 0) break; - eptr+= len; - } - break; - - default: - RRETURN(PCRE_ERROR_INTERNAL); - } - - /* eptr is now past the end of the maximum run */ - - for(;;) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - if (eptr-- == pp) break; /* Stop if tried at original pos */ - BACKCHAR(eptr); - } - } - else -#endif - - /* Not UTF-8 mode */ - { - switch(ctype) - { - case OP_ANY: - if ((ims & PCRE_DOTALL) == 0) - { - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || *eptr == NEWLINE) break; - eptr++; - } - break; - } - /* For DOTALL case, fall through and treat as \C */ - - case OP_ANYBYTE: - c = max - min; - if (c > md->end_subject - eptr) c = md->end_subject - eptr; - eptr += c; - break; - - case OP_NOT_DIGIT: - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || (md->ctypes[*eptr] & ctype_digit) != 0) - break; - eptr++; - } - break; - - case OP_DIGIT: - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || (md->ctypes[*eptr] & ctype_digit) == 0) - break; - eptr++; - } - break; - - case OP_NOT_WHITESPACE: - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || (md->ctypes[*eptr] & ctype_space) != 0) - break; - eptr++; - } - break; - - case OP_WHITESPACE: - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || (md->ctypes[*eptr] & ctype_space) == 0) - break; - eptr++; - } - break; - - case OP_NOT_WORDCHAR: - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || (md->ctypes[*eptr] & ctype_word) != 0) - break; - eptr++; - } - break; - - case OP_WORDCHAR: - for (i = min; i < max; i++) - { - if (eptr >= md->end_subject || (md->ctypes[*eptr] & ctype_word) == 0) - break; - eptr++; - } - break; - - default: - RRETURN(PCRE_ERROR_INTERNAL); - } - - /* eptr is now past the end of the maximum run */ - - while (eptr >= pp) - { - RMATCH(rrc, eptr, ecode, offset_top, md, ims, eptrb, 0); - eptr--; - if (rrc != MATCH_NOMATCH) RRETURN(rrc); - } - } - - /* Get here if we can't make it match with any permitted repetitions */ - - RRETURN(MATCH_NOMATCH); - } - /* Control never gets here */ - - /* There's been some horrible disaster. Since all codes > OP_BRA are - for capturing brackets, and there shouldn't be any gaps between 0 and - OP_BRA, arrival here can only mean there is something seriously wrong - in the code above or the OP_xxx definitions. */ - - default: - DPRINTF(("Unknown opcode %d\n", *ecode)); - RRETURN(PCRE_ERROR_UNKNOWN_NODE); - } - - /* Do not stick any code in here without much thought; it is assumed - that "continue" in the code above comes out to here to repeat the main - loop. */ - - } /* End of main loop */ -/* Control never reaches here */ -} - - -/*************************************************************************** -**************************************************************************** - RECURSION IN THE match() FUNCTION - -Undefine all the macros that were defined above to handle this. */ - -#ifdef NO_RECURSE -#undef eptr -#undef ecode -#undef offset_top -#undef ims -#undef eptrb -#undef flags - -#undef callpat -#undef charptr -#undef data -#undef next -#undef pp -#undef prev -#undef saved_eptr - -#undef new_recursive - -#undef cur_is_word -#undef condition -#undef minimize -#undef prev_is_word - -#undef original_ims - -#undef ctype -#undef length -#undef max -#undef min -#undef number -#undef offset -#undef op -#undef save_capture_last -#undef save_offset1 -#undef save_offset2 -#undef save_offset3 -#undef stacksave - -#undef newptrb - -#endif - -/* These two are defined as macros in both cases */ - -#undef fc -#undef fi - -/*************************************************************************** -***************************************************************************/ - - - -/************************************************* -* Execute a Regular Expression * -*************************************************/ - -/* This function applies a compiled re to a subject string and picks out -portions of the string if it matches. Two elements in the vector are set for -each substring: the offsets to the start and end of the substring. - -Arguments: - argument_re points to the compiled expression - extra_data points to extra data or is NULL - subject points to the subject string - length length of subject string (may contain binary zeros) - start_offset where to start in the subject string - options option bits - offsets points to a vector of ints to be filled in with offsets - offsetcount the number of elements in the vector - -Returns: > 0 => success; value is the number of elements filled in - = 0 => success, but offsets is not big enough - -1 => failed to match - < -1 => some kind of unexpected problem -*/ - -EXPORT int -pcre_exec(const pcre *argument_re, const pcre_extra *extra_data, - const char *subject, int length, int start_offset, int options, int *offsets, - int offsetcount) -{ -int rc, resetcount, ocount; -int first_byte = -1; -int req_byte = -1; -int req_byte2 = -1; -unsigned long int ims = 0; -BOOL using_temporary_offsets = FALSE; -BOOL anchored; -BOOL startline; -BOOL first_byte_caseless = FALSE; -BOOL req_byte_caseless = FALSE; -match_data match_block; -const uschar *tables; -const uschar *start_bits = NULL; -const uschar *start_match = (const uschar *)subject + start_offset; -const uschar *end_subject; -const uschar *req_byte_ptr = start_match - 1; - -pcre_study_data internal_study; -const pcre_study_data *study; - -real_pcre internal_re; -const real_pcre *external_re = (const real_pcre *)argument_re; -const real_pcre *re = external_re; - -/* Plausibility checks */ - -if ((options & ~PUBLIC_EXEC_OPTIONS) != 0) return PCRE_ERROR_BADOPTION; -if (re == NULL || subject == NULL || - (offsets == NULL && offsetcount > 0)) return PCRE_ERROR_NULL; -if (offsetcount < 0) return PCRE_ERROR_BADCOUNT; - -/* Fish out the optional data from the extra_data structure, first setting -the default values. */ - -study = NULL; -match_block.match_limit = MATCH_LIMIT; -match_block.callout_data = NULL; - -/* The table pointer is always in native byte order. */ - -tables = external_re->tables; - -if (extra_data != NULL) - { - register unsigned int flags = extra_data->flags; - if ((flags & PCRE_EXTRA_STUDY_DATA) != 0) - study = (const pcre_study_data *)extra_data->study_data; - if ((flags & PCRE_EXTRA_MATCH_LIMIT) != 0) - match_block.match_limit = extra_data->match_limit; - if ((flags & PCRE_EXTRA_CALLOUT_DATA) != 0) - match_block.callout_data = extra_data->callout_data; - if ((flags & PCRE_EXTRA_TABLES) != 0) tables = extra_data->tables; - } - -/* If the exec call supplied NULL for tables, use the inbuilt ones. This -is a feature that makes it possible to save compiled regex and re-use them -in other programs later. */ - -if (tables == NULL) tables = pcre_default_tables; - -/* Check that the first field in the block is the magic number. If it is not, -test for a regex that was compiled on a host of opposite endianness. If this is -the case, flipped values are put in internal_re and internal_study if there was -study data too. */ - -if (re->magic_number != MAGIC_NUMBER) - { - re = try_flipped(re, &internal_re, study, &internal_study); - if (re == NULL) return PCRE_ERROR_BADMAGIC; - if (study != NULL) study = &internal_study; - } - -/* Set up other data */ - -anchored = ((re->options | options) & PCRE_ANCHORED) != 0; -startline = (re->options & PCRE_STARTLINE) != 0; - -/* The code starts after the real_pcre block and the capture name table. */ - -match_block.start_code = (const uschar *)external_re + re->name_table_offset + - re->name_count * re->name_entry_size; - -match_block.start_subject = (const uschar *)subject; -match_block.start_offset = start_offset; -match_block.end_subject = match_block.start_subject + length; -end_subject = match_block.end_subject; - -match_block.endonly = (re->options & PCRE_DOLLAR_ENDONLY) != 0; -match_block.utf8 = (re->options & PCRE_UTF8) != 0; - -match_block.notbol = (options & PCRE_NOTBOL) != 0; -match_block.noteol = (options & PCRE_NOTEOL) != 0; -match_block.notempty = (options & PCRE_NOTEMPTY) != 0; -match_block.partial = (options & PCRE_PARTIAL) != 0; -match_block.hitend = FALSE; - -match_block.recursive = NULL; /* No recursion at top level */ - -match_block.lcc = tables + lcc_offset; -match_block.ctypes = tables + ctypes_offset; - -/* Partial matching is supported only for a restricted set of regexes at the -moment. */ - -if (match_block.partial && (re->options & PCRE_NOPARTIAL) != 0) - return PCRE_ERROR_BADPARTIAL; - -/* Check a UTF-8 string if required. Unfortunately there's no way of passing -back the character offset. */ - -#ifdef SUPPORT_UTF8 -if (match_block.utf8 && (options & PCRE_NO_UTF8_CHECK) == 0) - { - if (valid_utf8((uschar *)subject, length) >= 0) - return PCRE_ERROR_BADUTF8; - if (start_offset > 0 && start_offset < length) - { - int tb = ((uschar *)subject)[start_offset]; - if (tb > 127) - { - tb &= 0xc0; - if (tb != 0 && tb != 0xc0) return PCRE_ERROR_BADUTF8_OFFSET; - } - } - } -#endif - -/* The ims options can vary during the matching as a result of the presence -of (?ims) items in the pattern. They are kept in a local variable so that -restoring at the exit of a group is easy. */ - -ims = re->options & (PCRE_CASELESS|PCRE_MULTILINE|PCRE_DOTALL); - -/* If the expression has got more back references than the offsets supplied can -hold, we get a temporary chunk of working store to use during the matching. -Otherwise, we can use the vector supplied, rounding down its size to a multiple -of 3. */ - -ocount = offsetcount - (offsetcount % 3); - -if (re->top_backref > 0 && re->top_backref >= ocount/3) - { - ocount = re->top_backref * 3 + 3; - match_block.offset_vector = (int *)(pcre_malloc)(ocount * sizeof(int)); - if (match_block.offset_vector == NULL) return PCRE_ERROR_NOMEMORY; - using_temporary_offsets = TRUE; - DPRINTF(("Got memory to hold back references\n")); - } -else match_block.offset_vector = offsets; - -match_block.offset_end = ocount; -match_block.offset_max = (2*ocount)/3; -match_block.offset_overflow = FALSE; -match_block.capture_last = -1; - -/* Compute the minimum number of offsets that we need to reset each time. Doing -this makes a huge difference to execution time when there aren't many brackets -in the pattern. */ - -resetcount = 2 + re->top_bracket * 2; -if (resetcount > offsetcount) resetcount = ocount; - -/* Reset the working variable associated with each extraction. These should -never be used unless previously set, but they get saved and restored, and so we -initialize them to avoid reading uninitialized locations. */ - -if (match_block.offset_vector != NULL) - { - register int *iptr = match_block.offset_vector + ocount; - register int *iend = iptr - resetcount/2 + 1; - while (--iptr >= iend) *iptr = -1; - } - -/* Set up the first character to match, if available. The first_byte value is -never set for an anchored regular expression, but the anchoring may be forced -at run time, so we have to test for anchoring. The first char may be unset for -an unanchored pattern, of course. If there's no first char and the pattern was -studied, there may be a bitmap of possible first characters. */ - -if (!anchored) - { - if ((re->options & PCRE_FIRSTSET) != 0) - { - first_byte = re->first_byte & 255; - if ((first_byte_caseless = ((re->first_byte & REQ_CASELESS) != 0)) == TRUE) - first_byte = match_block.lcc[first_byte]; - } - else - if (!startline && study != NULL && - (study->options & PCRE_STUDY_MAPPED) != 0) - start_bits = study->start_bits; - } - -/* For anchored or unanchored matches, there may be a "last known required -character" set. */ - -if ((re->options & PCRE_REQCHSET) != 0) - { - req_byte = re->req_byte & 255; - req_byte_caseless = (re->req_byte & REQ_CASELESS) != 0; - req_byte2 = (tables + fcc_offset)[req_byte]; /* case flipped */ - } - -/* Loop for handling unanchored repeated matching attempts; for anchored regexs -the loop runs just once. */ - -do - { - /* Reset the maximum number of extractions we might see. */ - - if (match_block.offset_vector != NULL) - { - register int *iptr = match_block.offset_vector; - register int *iend = iptr + resetcount; - while (iptr < iend) *iptr++ = -1; - } - - /* Advance to a unique first char if possible */ - - if (first_byte >= 0) - { - if (first_byte_caseless) - while (start_match < end_subject && - match_block.lcc[*start_match] != first_byte) - start_match++; - else - while (start_match < end_subject && *start_match != first_byte) - start_match++; - } - - /* Or to just after \n for a multiline match if possible */ - - else if (startline) - { - if (start_match > match_block.start_subject + start_offset) - { - while (start_match < end_subject && start_match[-1] != NEWLINE) - start_match++; - } - } - - /* Or to a non-unique first char after study */ - - else if (start_bits != NULL) - { - while (start_match < end_subject) - { - register unsigned int c = *start_match; - if ((start_bits[c/8] & (1 << (c&7))) == 0) start_match++; else break; - } - } - -#ifdef DEBUG /* Sigh. Some compilers never learn. */ - printf(">>>> Match against: "); - pchars(start_match, end_subject - start_match, TRUE, &match_block); - printf("\n"); -#endif - - /* If req_byte is set, we know that that character must appear in the subject - for the match to succeed. If the first character is set, req_byte must be - later in the subject; otherwise the test starts at the match point. This - optimization can save a huge amount of backtracking in patterns with nested - unlimited repeats that aren't going to match. Writing separate code for - cased/caseless versions makes it go faster, as does using an autoincrement - and backing off on a match. - - HOWEVER: when the subject string is very, very long, searching to its end can - take a long time, and give bad performance on quite ordinary patterns. This - showed up when somebody was matching /^C/ on a 32-megabyte string... so we - don't do this when the string is sufficiently long. - - ALSO: this processing is disabled when partial matching is requested. - */ - - if (req_byte >= 0 && - end_subject - start_match < REQ_BYTE_MAX && - !match_block.partial) - { - register const uschar *p = start_match + ((first_byte >= 0)? 1 : 0); - - /* We don't need to repeat the search if we haven't yet reached the - place we found it at last time. */ - - if (p > req_byte_ptr) - { - if (req_byte_caseless) - { - while (p < end_subject) - { - register int pp = *p++; - if (pp == req_byte || pp == req_byte2) { p--; break; } - } - } - else - { - while (p < end_subject) - { - if (*p++ == req_byte) { p--; break; } - } - } - - /* If we can't find the required character, break the matching loop */ - - if (p >= end_subject) break; - - /* If we have found the required character, save the point where we - found it, so that we don't search again next time round the loop if - the start hasn't passed this character yet. */ - - req_byte_ptr = p; - } - } - - /* When a match occurs, substrings will be set for all internal extractions; - we just need to set up the whole thing as substring 0 before returning. If - there were too many extractions, set the return code to zero. In the case - where we had to get some local store to hold offsets for backreferences, copy - those back references that we can. In this case there need not be overflow - if certain parts of the pattern were not used. */ - - match_block.start_match = start_match; - match_block.match_call_count = 0; - - rc = match(start_match, match_block.start_code, 2, &match_block, ims, NULL, - match_isgroup); - - if (rc == MATCH_NOMATCH) - { - start_match++; -#ifdef SUPPORT_UTF8 - if (match_block.utf8) - while(start_match < end_subject && (*start_match & 0xc0) == 0x80) - start_match++; -#endif - continue; - } - - if (rc != MATCH_MATCH) - { - DPRINTF((">>>> error: returning %d\n", rc)); - return rc; - } - - /* We have a match! Copy the offset information from temporary store if - necessary */ - - if (using_temporary_offsets) - { - if (offsetcount >= 4) - { - memcpy(offsets + 2, match_block.offset_vector + 2, - (offsetcount - 2) * sizeof(int)); - DPRINTF(("Copied offsets from temporary memory\n")); - } - if (match_block.end_offset_top > offsetcount) - match_block.offset_overflow = TRUE; - - DPRINTF(("Freeing temporary memory\n")); - (pcre_free)(match_block.offset_vector); - } - - rc = match_block.offset_overflow? 0 : match_block.end_offset_top/2; - - if (offsetcount < 2) rc = 0; else - { - offsets[0] = start_match - match_block.start_subject; - offsets[1] = match_block.end_match_ptr - match_block.start_subject; - } - - DPRINTF((">>>> returning %d\n", rc)); - return rc; - } - -/* This "while" is the end of the "do" above */ - -while (!anchored && start_match <= end_subject); - -if (using_temporary_offsets) - { - DPRINTF(("Freeing temporary memory\n")); - (pcre_free)(match_block.offset_vector); - } - -if (match_block.partial && match_block.hitend) - { - DPRINTF((">>>> returning PCRE_ERROR_PARTIAL\n")); - return PCRE_ERROR_PARTIAL; - } -else - { - DPRINTF((">>>> returning PCRE_ERROR_NOMATCH\n")); - return PCRE_ERROR_NOMATCH; - } -} - -/* End of pcre.c */ diff --git a/tools/capone/src/pcre/pcre.h b/tools/capone/src/pcre/pcre.h deleted file mode 100644 index ee5bf16..0000000 --- a/tools/capone/src/pcre/pcre.h +++ /dev/null @@ -1,239 +0,0 @@ -/************************************************* -* Perl-Compatible Regular Expressions * -*************************************************/ - -/* In its original form, this is the .in file that is transformed by -"configure" into pcre.h. - - Copyright (c) 1997-2004 University of Cambridge - ------------------------------------------------------------------------------ -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - * Neither the name of the University of Cambridge nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. ------------------------------------------------------------------------------ -*/ - -#ifndef _PCRE_H -#define _PCRE_H - -/* The file pcre.h is build by "configure". Do not edit it; instead -make changes to pcre.in. */ - -#define PCRE_MAJOR 5 -#define PCRE_MINOR 0 -#define PCRE_DATE 13-Sep-2004 - -/* Win32 uses DLL by default */ - -#ifdef _WIN32 -# ifdef PCRE_DEFINITION -# ifdef DLL_EXPORT -# define PCRE_DATA_SCOPE __declspec(dllexport) -# endif -# else -# ifndef PCRE_STATIC -# define PCRE_DATA_SCOPE extern __declspec(dllimport) -# endif -# endif -#endif -#ifndef PCRE_DATA_SCOPE -# define PCRE_DATA_SCOPE extern -#endif - -/* Have to include stdlib.h in order to ensure that size_t is defined; -it is needed here for malloc. */ - -#include - -/* Allow for C++ users */ - -#ifdef __cplusplus -extern "C" { -#endif - -/* Options */ - -#define PCRE_CASELESS 0x0001 -#define PCRE_MULTILINE 0x0002 -#define PCRE_DOTALL 0x0004 -#define PCRE_EXTENDED 0x0008 -#define PCRE_ANCHORED 0x0010 -#define PCRE_DOLLAR_ENDONLY 0x0020 -#define PCRE_EXTRA 0x0040 -#define PCRE_NOTBOL 0x0080 -#define PCRE_NOTEOL 0x0100 -#define PCRE_UNGREEDY 0x0200 -#define PCRE_NOTEMPTY 0x0400 -#define PCRE_UTF8 0x0800 -#define PCRE_NO_AUTO_CAPTURE 0x1000 -#define PCRE_NO_UTF8_CHECK 0x2000 -#define PCRE_AUTO_CALLOUT 0x4000 -#define PCRE_PARTIAL 0x8000 - -/* Exec-time and get/set-time error codes */ - -#define PCRE_ERROR_NOMATCH (-1) -#define PCRE_ERROR_NULL (-2) -#define PCRE_ERROR_BADOPTION (-3) -#define PCRE_ERROR_BADMAGIC (-4) -#define PCRE_ERROR_UNKNOWN_NODE (-5) -#define PCRE_ERROR_NOMEMORY (-6) -#define PCRE_ERROR_NOSUBSTRING (-7) -#define PCRE_ERROR_MATCHLIMIT (-8) -#define PCRE_ERROR_CALLOUT (-9) /* Never used by PCRE itself */ -#define PCRE_ERROR_BADUTF8 (-10) -#define PCRE_ERROR_BADUTF8_OFFSET (-11) -#define PCRE_ERROR_PARTIAL (-12) -#define PCRE_ERROR_BADPARTIAL (-13) -#define PCRE_ERROR_INTERNAL (-14) -#define PCRE_ERROR_BADCOUNT (-15) - -/* Request types for pcre_fullinfo() */ - -#define PCRE_INFO_OPTIONS 0 -#define PCRE_INFO_SIZE 1 -#define PCRE_INFO_CAPTURECOUNT 2 -#define PCRE_INFO_BACKREFMAX 3 -#define PCRE_INFO_FIRSTBYTE 4 -#define PCRE_INFO_FIRSTCHAR 4 /* For backwards compatibility */ -#define PCRE_INFO_FIRSTTABLE 5 -#define PCRE_INFO_LASTLITERAL 6 -#define PCRE_INFO_NAMEENTRYSIZE 7 -#define PCRE_INFO_NAMECOUNT 8 -#define PCRE_INFO_NAMETABLE 9 -#define PCRE_INFO_STUDYSIZE 10 -#define PCRE_INFO_DEFAULT_TABLES 11 - -/* Request types for pcre_config() */ - -#define PCRE_CONFIG_UTF8 0 -#define PCRE_CONFIG_NEWLINE 1 -#define PCRE_CONFIG_LINK_SIZE 2 -#define PCRE_CONFIG_POSIX_MALLOC_THRESHOLD 3 -#define PCRE_CONFIG_MATCH_LIMIT 4 -#define PCRE_CONFIG_STACKRECURSE 5 -#define PCRE_CONFIG_UNICODE_PROPERTIES 6 - -/* Bit flags for the pcre_extra structure */ - -#define PCRE_EXTRA_STUDY_DATA 0x0001 -#define PCRE_EXTRA_MATCH_LIMIT 0x0002 -#define PCRE_EXTRA_CALLOUT_DATA 0x0004 -#define PCRE_EXTRA_TABLES 0x0008 - -/* Types */ - -struct real_pcre; /* declaration; the definition is private */ -typedef struct real_pcre pcre; - -/* The structure for passing additional data to pcre_exec(). This is defined in -such as way as to be extensible. Always add new fields at the end, in order to -remain compatible. */ - -typedef struct pcre_extra { - unsigned long int flags; /* Bits for which fields are set */ - void *study_data; /* Opaque data from pcre_study() */ - unsigned long int match_limit; /* Maximum number of calls to match() */ - void *callout_data; /* Data passed back in callouts */ - const unsigned char *tables; /* Pointer to character tables */ -} pcre_extra; - -/* The structure for passing out data via the pcre_callout_function. We use a -structure so that new fields can be added on the end in future versions, -without changing the API of the function, thereby allowing old clients to work -without modification. */ - -typedef struct pcre_callout_block { - int version; /* Identifies version of block */ - /* ------------------------ Version 0 ------------------------------- */ - int callout_number; /* Number compiled into pattern */ - int *offset_vector; /* The offset vector */ - const char *subject; /* The subject being matched */ - int subject_length; /* The length of the subject */ - int start_match; /* Offset to start of this match attempt */ - int current_position; /* Where we currently are in the subject */ - int capture_top; /* Max current capture */ - int capture_last; /* Most recently closed capture */ - void *callout_data; /* Data passed in with the call */ - /* ------------------- Added for Version 1 -------------------------- */ - int pattern_position; /* Offset to next item in the pattern */ - int next_item_length; /* Length of next item in the pattern */ - /* ------------------------------------------------------------------ */ -} pcre_callout_block; - -/* Indirection for store get and free functions. These can be set to -alternative malloc/free functions if required. Special ones are used in the -non-recursive case for "frames". There is also an optional callout function -that is triggered by the (?) regex item. Some magic is required for Win32 DLL; -it is null on other OS. For Virtual Pascal, these have to be different again. -*/ - -#ifndef VPCOMPAT -PCRE_DATA_SCOPE void *(*pcre_malloc)(size_t); -PCRE_DATA_SCOPE void (*pcre_free)(void *); -PCRE_DATA_SCOPE void *(*pcre_stack_malloc)(size_t); -PCRE_DATA_SCOPE void (*pcre_stack_free)(void *); -PCRE_DATA_SCOPE int (*pcre_callout)(pcre_callout_block *); -#else /* VPCOMPAT */ -extern void *pcre_malloc(size_t); -extern void pcre_free(void *); -extern void *pcre_stack_malloc(size_t); -extern void pcre_stack_free(void *); -extern int pcre_callout(pcre_callout_block *); -#endif /* VPCOMPAT */ - -/* Exported PCRE functions */ - -extern pcre *pcre_compile(const char *, int, const char **, - int *, const unsigned char *); -extern int pcre_config(int, void *); -extern int pcre_copy_named_substring(const pcre *, const char *, - int *, int, const char *, char *, int); -extern int pcre_copy_substring(const char *, int *, int, int, - char *, int); -extern int pcre_exec(const pcre *, const pcre_extra *, - const char *, int, int, int, int *, int); -extern void pcre_free_substring(const char *); -extern void pcre_free_substring_list(const char **); -extern int pcre_fullinfo(const pcre *, const pcre_extra *, int, - void *); -extern int pcre_get_named_substring(const pcre *, const char *, - int *, int, const char *, const char **); -extern int pcre_get_stringnumber(const pcre *, const char *); -extern int pcre_get_substring(const char *, int *, int, int, - const char **); -extern int pcre_get_substring_list(const char *, int *, int, - const char ***); -extern int pcre_info(const pcre *, int *, int *); -extern const unsigned char *pcre_maketables(void); -extern pcre_extra *pcre_study(const pcre *, int, const char **); -extern const char *pcre_version(void); - -#ifdef __cplusplus -} /* extern "C" */ -#endif - -#endif /* End of pcre.h */ diff --git a/tools/capone/src/re.cpp b/tools/capone/src/re.cpp deleted file mode 100644 index afeca46..0000000 --- a/tools/capone/src/re.cpp +++ /dev/null @@ -1,288 +0,0 @@ -#include -#include -#include - -extern "C" { -#define USE_INTERFACE 1 - -#include "scheme-private.h" -#include "scheme.h" -} - -#include "pcre/pcre.h" -#include "re.h" - -#define RE_VEC_COUNT (16 * 3) /* max sub expressions in PCRE */ - -#define car(p) ((p)->_object._cons._car) -#define cdr(p) ((p)->_object._cons._cdr) - -/* TODO: this is used in sys.cpp too. Move it somewhere else */ -pointer reverse_in_place(scheme *sc, pointer term, pointer list) { - pointer p = list, result = term, q; - - while (p != sc->NIL) { - q = cdr(p); - cdr(p) = result; - result = p; - p = q; - } - - return result; -} - -static pointer build_string(scheme* sc, const char* p, int len) { - char* str = (char*)malloc(len + 1); - if(!str) - return sc->NIL; - - char* ptr = str; - - for(int i = 0; i < len; i++) - *ptr++ = *p++; - *ptr = '\0'; - - pointer ret = mk_string(sc, str); - free(str); - - return ret; -} - -/* - * (re-split ) => ("list" "of" "splitted" "items") - * or return empty list if matched nothing or failed - */ -static pointer re_split(scheme* sc, pointer args) { - if(args == sc->NIL) - return args; - - pointer a; - const char* reg, *str; - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->NIL; - reg = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->NIL; - str = sc->vptr->string_value(a); - - const char* errstr; - int erroffset; - - pcre* p = pcre_compile(reg, 0, &errstr, &erroffset, NULL); - if(!p) { - printf("Failed to compile '%s' pattern\n", reg); - return sc->NIL; /* sc->NIL means empty list */ - } - - int ovector[RE_VEC_COUNT]; - int str_len = strlen(str); - int slen = str_len; - const char* sp = str; - - int ret = pcre_exec(p, NULL, sp, slen, 0, 0, ovector, RE_VEC_COUNT); - - /* check to see if we have anything before loop */ - if(ret == -1) { - free(p); - printf("No match\n"); - return sc->NIL; - } - - if(ret < 0) { - free(p); - printf("pcre_exec() failed\n"); - return sc->NIL; - } - - pointer lst_ret = sc->NIL; - - while(1) { - /* - * ovector[0] is num bytes before match - * ovector[1] is num bytes of match + ovector[0] - * so ovector[1] - ovector[0] is match length - */ - if((ovector[1] - ovector[0]) == 0) { - /* use last token after last match */ - lst_ret = cons(sc, build_string(sc, sp, slen), lst_ret); - break; - } - - lst_ret = cons(sc, build_string(sc, sp, ovector[0]), lst_ret); - - sp += ovector[1]; - slen -= ovector[1]; - ret = pcre_exec(p, NULL, sp, slen, 0, 0, ovector, RE_VEC_COUNT); - } - - free(p); - - /* reverse list due cons() property */ - return reverse_in_place(sc, sc->NIL, lst_ret); -} - -/* - * (re-match ) => ( ) - * or return empty list if matched nothing or failed - */ -static pointer re_match(scheme* sc, pointer args) { - if(args == sc->NIL) - return args; - - pointer a; - const char* reg, *str; - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->NIL; - reg = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->NIL; - str = sc->vptr->string_value(a); - - int start = 0, len = strlen(str); - - args = sc->vptr->pair_cdr(args); - a = sc->vptr->pair_car(args); - if(a != sc->NIL && sc->vptr->is_number(a)) { - start = sc->vptr->ivalue(a); - /* - * TODO: this will always return empty list - * Should this be 'start = 0' ? - */ - if(start > len) - start = len; - - if(start < 0) - start = 0; - } - - const char* errstr; - int erroffset; - - pcre* p = pcre_compile(reg, 0, &errstr, &erroffset, NULL); - if(!p) { - printf("Failed to compile '%s' pattern\n", reg); - return sc->NIL; /* sc->NIL means empty list */ - } - - int ovector[RE_VEC_COUNT]; - int ret = pcre_exec(p, NULL, str, len, start, 0, ovector, RE_VEC_COUNT); - free(p); - - if(ret >= 0) { - return cons(sc, mk_integer(sc, ovector[0]), - cons(sc, mk_integer(sc, ovector[1]), sc->NIL)); - } - - return sc->NIL; -} - -/* - * (re-replace ) => - * if given , only first pattern will be replaced - * or if nothing found - * TODO: it will return #f if parameters are wrong. Good? - */ -pointer re_replace(scheme* sc, pointer args) { - if(args == sc->NIL) - return sc->F; - - pointer a; - const char* reg, *target, *rep; - bool replace_all = true; - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - reg = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - target = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - rep = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - - /* TODO: here can be any integer that will be casted to bool */ - a = sc->vptr->pair_car(args); - if(a != sc->NIL && sc->vptr->is_number(a)) - replace_all = sc->vptr->ivalue(a); - - const char* errstr; - int erroffset; - - pcre* p = pcre_compile(reg, 0, &errstr, &erroffset, NULL); - if(!p) { - printf("Failed to compile '%s' pattern\n", reg); - return sc->F; - } - - int len = strlen(target); - int ovector[RE_VEC_COUNT]; - int ret = pcre_exec(p, NULL, target, len, 0, 0, ovector, RE_VEC_COUNT); - - if(ret >= 0) { - int rep_len = strlen(rep); - /* ovector[1] - ovector[0] is len of matched pattern */ - int nlen = len - (ovector[1] - ovector[0]) + rep_len; - char* newstr = (char*)malloc(nlen + 1); - - int i, j; - for(i = 0; i < ovector[0]; i++) - newstr[i] = target[i]; - for(j = 0; j < rep_len; i++, j++) - newstr[i] = rep[j]; - /* now copy the rest */ - for(j = ovector[1]; j < len; j++, i++) - newstr[i] = target[j]; - newstr[i] = '\0'; - - pointer s = mk_string(sc, newstr); - free(newstr); - free(p); - return s; - } - - free(p); - return mk_string(sc, target); -} - -void register_re_functions(scheme* sc) { - sc->vptr->scheme_define( - sc, - sc->global_env, - sc->vptr->mk_symbol(sc, "re-split"), - sc->vptr->mk_foreign_func(sc, re_split)); - - sc->vptr->scheme_define( - sc, - sc->global_env, - sc->vptr->mk_symbol(sc, "re-match"), - sc->vptr->mk_foreign_func(sc, re_match)); - - sc->vptr->scheme_define( - sc, - sc->global_env, - sc->vptr->mk_symbol(sc, "re-replace"), - sc->vptr->mk_foreign_func(sc, re_replace)); -} diff --git a/tools/capone/src/re.h b/tools/capone/src/re.h deleted file mode 100644 index aead36c..0000000 --- a/tools/capone/src/re.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef __RE_H__ -#define __RE_H__ - -void register_re_functions(scheme* sc); - -#endif diff --git a/tools/capone/src/scheme-private.h b/tools/capone/src/scheme-private.h deleted file mode 100644 index aab1a44..0000000 --- a/tools/capone/src/scheme-private.h +++ /dev/null @@ -1,189 +0,0 @@ -/* scheme-private.h */ - -#ifndef _SCHEME_PRIVATE_H -#define _SCHEME_PRIVATE_H - -#include "scheme.h" -/*------------------ Ugly internals -----------------------------------*/ -/*------------------ Of interest only to FFI users --------------------*/ - - -enum scheme_port_kind { - port_free=0, - port_file=1, - port_string=2, - port_input=16, - port_output=32 -}; - -typedef struct port { - unsigned char kind; - union { - struct { - FILE *file; - int closeit; - } stdio; - struct { - char *start; - char *past_the_end; - char *curr; - } string; - } rep; -} port; - -/* cell structure */ -struct cell { - unsigned int _flag; - union { - struct { - char *_svalue; - int _length; - } _string; - num _number; - port *_port; - foreign_func _ff; - struct { - struct cell *_car; - struct cell *_cdr; - } _cons; - } _object; -}; - -struct scheme { -/* arrays for segments */ -func_alloc malloc; -func_dealloc free; - -/* return code */ -int retcode; -int tracing; - -#define CELL_SEGSIZE 8000 /* # of cells in one segment, original was 5000 */ -#define CELL_NSEGMENT 100 /* # of segments for cells, original was 10 */ - -char *alloc_seg[CELL_NSEGMENT]; -pointer cell_seg[CELL_NSEGMENT]; -int last_cell_seg; - -/* We use 4 registers. */ -pointer args; /* register for arguments of function */ -pointer envir; /* stack register for current environment */ -pointer code; /* register for current code */ -pointer dump; /* stack register for next evaluation */ - -int interactive_repl; /* are we in an interactive REPL? */ - -struct cell _sink; -pointer sink; /* when mem. alloc. fails */ -struct cell _NIL; -pointer NIL; /* special cell representing empty cell */ -struct cell _HASHT; -pointer T; /* special cell representing #t */ -struct cell _HASHF; -pointer F; /* special cell representing #f */ -struct cell _EOF_OBJ; -pointer EOF_OBJ; /* special cell representing end-of-file object */ -pointer oblist; /* pointer to symbol table */ -pointer global_env; /* pointer to global environment */ - -/* global pointers to special symbols */ -pointer LAMBDA; /* pointer to syntax lambda */ -pointer LAMBDA2; /* pointer to syntax lambda (fn) */ -pointer QUOTE; /* pointer to syntax quote */ - -pointer QQUOTE; /* pointer to symbol quasiquote */ -pointer UNQUOTE; /* pointer to symbol unquote */ -pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ -pointer FEED_TO; /* => */ -pointer COLON_HOOK; /* *colon-hook* */ -pointer ERROR_HOOK; /* *error-hook* */ -pointer SHARP_HOOK; /* *sharp-hook* */ - -pointer free_cell; /* pointer to top of free cells */ -long fcells; /* # of free cells */ - -pointer inport; -pointer outport; -pointer save_inport; -pointer loadport; - -#define MAXFIL 64 -port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ -int nesting_stack[MAXFIL]; -int file_i; -int nesting; - -char gc_verbose; /* if gc_verbose is not zero, print gc status */ -char no_memory; /* Whether mem. alloc. has failed */ - -#define LINESIZE 1024 -char linebuff[LINESIZE]; -char strbuff[256]; - -FILE *tmpfp; -int tok; -int print_flag; -pointer value; -int op; - -void *ext_data; /* For the benefit of foreign functions */ -long gensym_cnt; - -struct scheme_interface *vptr; -void *dump_base; /* pointer to base of allocated dump stack */ -int dump_size; /* number of frames allocated for dump stack */ -}; - -/* operator code */ -enum scheme_opcodes { -#define _OP_DEF(A,B,C,D,E,OP) OP, -#include "opdefines.h" - OP_MAXDEFINED -}; - - -#define cons(sc,a,b) _cons(sc,a,b,0) -#define immutable_cons(sc,a,b) _cons(sc,a,b,1) - -int is_string(pointer p); -char *string_value(pointer p); -int is_number(pointer p); -num nvalue(pointer p); -long ivalue(pointer p); -double rvalue(pointer p); -int is_integer(pointer p); -int is_real(pointer p); -int is_character(pointer p); -long charvalue(pointer p); -int is_vector(pointer p); - -int is_port(pointer p); - -int is_pair(pointer p); -pointer pair_car(pointer p); -pointer pair_cdr(pointer p); -pointer set_car(pointer p, pointer q); -pointer set_cdr(pointer p, pointer q); - -int is_symbol(pointer p); -char *symname(pointer p); -int hasprop(pointer p); - -int is_syntax(pointer p); -int is_proc(pointer p); -int is_foreign(pointer p); -char *syntaxname(pointer p); -int is_closure(pointer p); -#ifdef USE_MACRO -int is_macro(pointer p); -#endif -pointer closure_code(pointer p); -pointer closure_env(pointer p); - -int is_continuation(pointer p); -int is_promise(pointer p); -int is_environment(pointer p); -int is_immutable(pointer p); -void setimmutable(pointer p); - -#endif diff --git a/tools/capone/src/scheme.c b/tools/capone/src/scheme.c deleted file mode 100644 index edfb8bc..0000000 --- a/tools/capone/src/scheme.c +++ /dev/null @@ -1,4454 +0,0 @@ -/* T I N Y S C H E M E 1 . 3 9 - * Dimitrios Souflis (dsouflis@acm.org) - * Based on MiniScheme (original credits follow) - * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) - * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp - * (MINISCM) This version has been modified by R.C. Secrist. - * (MINISCM) - * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. - * (MINISCM) - * (MINISCM) This is a revised and modified version by Akira KIDA. - * (MINISCM) current version is 0.85k4 (15 May 1994) - * - */ - -#define _SCHEME_SOURCE -#include "scheme-private.h" -#ifndef WIN32 -# include -#endif -/*#if USE_DL -# include "dynload.h" -#endif*/ -#if USE_MATH -# include -#endif -#include -#include -#include - -#if USE_STRCASECMP -#include -# ifndef __APPLE__ -# define stricmp strcasecmp -# endif -#endif - -/* Used for documentation purposes, to signal functions in 'interface' */ -#define INTERFACE - -#define TOK_EOF (-1) -#define TOK_LPAREN 0 -#define TOK_RPAREN 1 -#define TOK_DOT 2 -#define TOK_ATOM 3 -#define TOK_QUOTE 4 -#define TOK_COMMENT 5 -#define TOK_DQUOTE 6 -#define TOK_BQUOTE 7 -#define TOK_COMMA 8 -#define TOK_ATMARK 9 -#define TOK_SHARP 10 -#define TOK_SHARP_CONST 11 -#define TOK_VEC 12 - -# define BACKQUOTE '`' - -/* - * Basic memory allocation units - */ - -#include -#include -#ifndef __APPLE__ -# include -#else -static int stricmp(const char *s1, const char *s2) -{ - unsigned char c1, c2; - do { - c1 = tolower(*s1); - c2 = tolower(*s2); - if (c1 < c2) - return -1; - else if (c1 > c2) - return 1; - s1++, s2++; - } while (c1 != 0); - return 0; -} -#endif /* __APPLE__ */ - -#if USE_STRLWR -static const char *strlwr(char *s) { - const char *p=s; - while(*s) { - *s=tolower(*s); - s++; - } - return p; -} -#endif - -#ifndef prompt -# define prompt ">>> " -#endif - -#ifndef ErrorHeader -# define ErrorHeader "*** Error: " -#endif - -#ifndef FIRST_CELLSEGS -# define FIRST_CELLSEGS 3 -#endif - -enum scheme_types { - T_STRING=1, - T_NUMBER=2, - T_SYMBOL=3, - T_PROC=4, - T_PAIR=5, - T_CLOSURE=6, - T_CONTINUATION=7, - T_FOREIGN=8, - T_CHARACTER=9, - T_PORT=10, - T_VECTOR=11, - T_MACRO=12, - T_PROMISE=13, - T_ENVIRONMENT=14, - T_LAST_SYSTEM_TYPE=14 -}; - -/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ -#define ADJ 32 -#define TYPE_BITS 5 -#define T_MASKTYPE 31 /* 0000000000011111 */ -#define T_SYNTAX 4096 /* 0001000000000000 */ -#define T_IMMUTABLE 8192 /* 0010000000000000 */ -#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ -#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ -#define MARK 32768 /* 1000000000000000 */ -#define UNMARK 32767 /* 0111111111111111 */ - -static num num_add(num a, num b); -static num num_mul(num a, num b); -static num num_div(num a, num b); -static num num_intdiv(num a, num b); -static num num_sub(num a, num b); -static num num_rem(num a, num b); -static num num_mod(num a, num b); -static int num_eq(num a, num b); -static int num_gt(num a, num b); -static int num_ge(num a, num b); -static int num_lt(num a, num b); -static int num_le(num a, num b); - -#if USE_MATH -static double round_per_R5RS(double x); -#endif -static int is_zero_double(double x); - -static num num_zero; -static num num_one; - -/* macros for cell operations */ -#define typeflag(p) ((p)->_flag) -#define type(p) (typeflag(p)&T_MASKTYPE) - -INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } -#define strvalue(p) ((p)->_object._string._svalue) -#define strlength(p) ((p)->_object._string._length) - -INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } -INTERFACE static void fill_vector(pointer vec, pointer obj); -INTERFACE static pointer vector_elem(pointer vec, int ielem); -INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); -INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } -INTERFACE INLINE int is_integer(pointer p) { - return ((p)->_object._number.is_fixnum); -} -INTERFACE INLINE int is_real(pointer p) { - return (!(p)->_object._number.is_fixnum); -} - -INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } -INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } -INLINE num nvalue(pointer p) { return ((p)->_object._number); } -INTERFACE long ivalue(pointer p) { return (is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } -INTERFACE double rvalue(pointer p) { return (!is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } -#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) -#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) -#define set_integer(p) (p)->_object._number.is_fixnum=1; -#define set_real(p) (p)->_object._number.is_fixnum=0; -INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } - -INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } -#define is_inport(p) (type(p)==T_PORT && p->_object._port->kind&port_input) -#define is_outport(p) (type(p)==T_PORT && p->_object._port->kind&port_output) - -INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } -#define car(p) ((p)->_object._cons._car) -#define cdr(p) ((p)->_object._cons._cdr) -INTERFACE pointer pair_car(pointer p) { return car(p); } -INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } -INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } -INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } - -INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } -INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } -#if USE_PLIST -SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); } -#define symprop(p) cdr(p) -#endif - -INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } -INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } -INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } -INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } -#define procnum(p) ivalue(p) -static const char *procname(pointer x); - -INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } -INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } -INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } -INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } - -INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } -#define cont_dump(p) cdr(p) - -/* To do: promise should be forced ONCE only */ -INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } - -INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } -#define setenvironment(p) typeflag(p) = T_ENVIRONMENT - -#define is_atom(p) (typeflag(p)&T_ATOM) -#define setatom(p) typeflag(p) |= T_ATOM -#define clratom(p) typeflag(p) &= CLRATOM - -#define is_mark(p) (typeflag(p)&MARK) -#define setmark(p) typeflag(p) |= MARK -#define clrmark(p) typeflag(p) &= UNMARK - -INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } -/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ -INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } - -#define caar(p) car(car(p)) -#define cadr(p) car(cdr(p)) -#define cdar(p) cdr(car(p)) -#define cddr(p) cdr(cdr(p)) -#define cadar(p) car(cdr(car(p))) -#define caddr(p) car(cdr(cdr(p))) -#define cadaar(p) car(cdr(car(car(p)))) -#define cadddr(p) car(cdr(cdr(cdr(p)))) -#define cddddr(p) cdr(cdr(cdr(cdr(p)))) - -#if USE_CHAR_CLASSIFIERS -static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } -static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } -static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } -static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } -static INLINE int Cislower(int c) { return isascii(c) && islower(c); } -#endif - -#if USE_ASCII_NAMES -static const char *charnames[32]={ - "nul", - "soh", - "stx", - "etx", - "eot", - "enq", - "ack", - "bel", - "bs", - "ht", - "lf", - "vt", - "ff", - "cr", - "so", - "si", - "dle", - "dc1", - "dc2", - "dc3", - "dc4", - "nak", - "syn", - "etb", - "can", - "em", - "sub", - "esc", - "fs", - "gs", - "rs", - "us" -}; - -static int is_ascii_name(const char *name, int *pc) { - int i; - for(i=0; i<32; i++) { - if(stricmp(name,charnames[i])==0) { - *pc=i; - return 1; - } - } - if(stricmp(name,"del")==0) { - *pc=127; - return 1; - } - return 0; -} - -#endif - -static int file_push(scheme *sc, const char *fname); -static void file_pop(scheme *sc); -static int file_interactive(scheme *sc); -static INLINE int is_one_of(char *s, int c); -static int alloc_cellseg(scheme *sc, int n); -static long binary_decode(const char *s); -static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); -static pointer _get_cell(scheme *sc, pointer a, pointer b); -static pointer reserve_cells(scheme *sc, int n); -static pointer get_consecutive_cells(scheme *sc, int n); -static pointer find_consecutive_cells(scheme *sc, int n); -static void finalize_cell(scheme *sc, pointer a); -static int count_consecutive_cells(pointer x, int needed); -static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); -static pointer mk_number(scheme *sc, num n); -static pointer mk_empty_string(scheme *sc, int len, char fill); -static char *store_string(scheme *sc, int len, const char *str, char fill); -static pointer mk_vector(scheme *sc, int len); -static pointer mk_atom(scheme *sc, char *q); -static pointer mk_sharp_const(scheme *sc, char *name); -static pointer mk_port(scheme *sc, port *p); -static pointer port_from_filename(scheme *sc, const char *fn, int prop); -static pointer port_from_file(scheme *sc, FILE *, int prop); -static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); -static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); -static port *port_rep_from_file(scheme *sc, FILE *, int prop); -static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); -static void port_close(scheme *sc, pointer p, int flag); -static void mark(pointer a); -static void gc(scheme *sc, pointer a, pointer b); -static int basic_inchar(port *pt); -static int inchar(scheme *sc); -static void backchar(scheme *sc, int c); -static char *readstr_upto(scheme *sc, char *delim); -static pointer readstrexp(scheme *sc); -static INLINE void skipspace(scheme *sc); -static int token(scheme *sc); -static void printslashstring(scheme *sc, char *s, int len); -static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); -static void printatom(scheme *sc, pointer l, int f); -static pointer mk_proc(scheme *sc, enum scheme_opcodes op); -static pointer mk_closure(scheme *sc, pointer c, pointer e); -static pointer mk_continuation(scheme *sc, pointer d); -static pointer reverse(scheme *sc, pointer a); -static pointer reverse_in_place(scheme *sc, pointer term, pointer list); -static pointer append(scheme *sc, pointer a, pointer b); -static int list_length(scheme *sc, pointer a); -static int eqv(pointer a, pointer b); -static INLINE void dump_stack_mark(scheme *); -static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_1(scheme *sc, enum scheme_opcodes op); -static pointer opexe_2(scheme *sc, enum scheme_opcodes op); -static pointer opexe_3(scheme *sc, enum scheme_opcodes op); -static pointer opexe_4(scheme *sc, enum scheme_opcodes op); -static pointer opexe_5(scheme *sc, enum scheme_opcodes op); -static pointer opexe_6(scheme *sc, enum scheme_opcodes op); -static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); -static void assign_syntax(scheme *sc, char *name); -static int syntaxnum(pointer p); -static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); - -#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) -#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) - -static num num_add(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue+b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)+num_rvalue(b); - } - return ret; -} - -static num num_mul(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue*b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)*num_rvalue(b); - } - return ret; -} - -static num num_div(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue/b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)/num_rvalue(b); - } - return ret; -} - -static num num_intdiv(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue/b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)/num_rvalue(b); - } - return ret; -} - -static num num_sub(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue-b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)-num_rvalue(b); - } - return ret; -} - -static num num_rem(num a, num b) { - num ret; - long e1, e2, res; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - e1=num_ivalue(a); - e2=num_ivalue(b); - res=e1%e2; - /* modulo should have same sign as second operand */ - if (res > 0) { - if (e1 < 0) { - res -= labs(e2); - } - } else if (res < 0) { - if (e1 > 0) { - res += labs(e2); - } - } - ret.value.ivalue=res; - return ret; -} - -static num num_mod(num a, num b) { - num ret; - long e1, e2, res; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - e1=num_ivalue(a); - e2=num_ivalue(b); - res=e1%e2; - if(res*e2<0) { /* modulo should have same sign as second operand */ - e2=labs(e2); - if(res>0) { - res-=e2; - } else { - res+=e2; - } - } - ret.value.ivalue=res; - return ret; -} - -static int num_eq(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivalue==b.value.ivalue; - } else { - ret=num_rvalue(a)==num_rvalue(b); - } - return ret; -} - - -static int num_gt(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivalue>b.value.ivalue; - } else { - ret=num_rvalue(a)>num_rvalue(b); - } - return ret; -} - -static int num_ge(num a, num b) { - return !num_lt(a,b); -} - -static int num_lt(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivaluedce) { - return ce; - } else if(dfl-DBL_MIN; -} - -static long binary_decode(const char *s) { - long x=0; - - while(*s!=0 && (*s=='1' || *s=='0')) { - x<<=1; - x+=*s-'0'; - s++; - } - - return x; -} - -/* allocate new cell segment */ -static int alloc_cellseg(scheme *sc, int n) { - pointer newp; - pointer last; - pointer p; - char *cp; - long i; - int k; - int adj=ADJ; - - if(adjlast_cell_seg >= CELL_NSEGMENT - 1) - return k; - cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); - if (cp == 0) - return k; - i = ++sc->last_cell_seg ; - sc->alloc_seg[i] = cp; - /* adjust in TYPE_BITS-bit boundary */ - if(((unsigned)cp)%adj!=0) { - cp=(char*)(adj*((unsigned long)cp/adj+1)); - } - /* insert new segment in address order */ - newp=(pointer)cp; - sc->cell_seg[i] = newp; - while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { - p = sc->cell_seg[i]; - sc->cell_seg[i] = sc->cell_seg[i - 1]; - sc->cell_seg[--i] = p; - } - sc->fcells += CELL_SEGSIZE; - last = newp + CELL_SEGSIZE - 1; - for (p = newp; p <= last; p++) { - typeflag(p) = 0; - cdr(p) = p + 1; - car(p) = sc->NIL; - } - /* insert new cells in address order on free list */ - if (sc->free_cell == sc->NIL || p < sc->free_cell) { - cdr(last) = sc->free_cell; - sc->free_cell = newp; - } else { - p = sc->free_cell; - while (cdr(p) != sc->NIL && newp > cdr(p)) - p = cdr(p); - cdr(last) = cdr(p); - cdr(p) = newp; - } - } - return n; -} - -static INLINE pointer get_cell(scheme *sc, pointer a, pointer b) { - if (sc->free_cell != sc->NIL) { - pointer x = sc->free_cell; - sc->free_cell = cdr(x); - --sc->fcells; - return (x); - } - return _get_cell (sc, a, b); -} - - -/* get new cell. parameter a, b is marked by gc. */ -static pointer _get_cell(scheme *sc, pointer a, pointer b) { - pointer x; - - if(sc->no_memory) { - return sc->sink; - } - - if (sc->free_cell == sc->NIL) { - gc(sc,a, b); - if (sc->fcells < sc->last_cell_seg*8 - || sc->free_cell == sc->NIL) { - /* if only a few recovered, get more to avoid fruitless gc's */ - if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { - sc->no_memory=1; - return sc->sink; - } - } - } - x = sc->free_cell; - sc->free_cell = cdr(x); - --sc->fcells; - return (x); -} - -/* make sure that there is a given number of cells free */ -static pointer reserve_cells(scheme *sc, int n) { - if(sc->no_memory) { - return sc->NIL; - } - - /* Are there enough cells available? */ - if (sc->fcells < n) { - /* If not, try gc'ing some */ - gc(sc, sc->NIL, sc->NIL); - if (sc->fcells < n) { - /* If there still aren't, try getting more heap */ - if (!alloc_cellseg(sc,1)) { - sc->no_memory=1; - return sc->NIL; - } - } - if (sc->fcells < n) { - /* If all fail, report failure */ - sc->no_memory=1; - return sc->NIL; - } - } - return (sc->T); -} - -static pointer get_consecutive_cells(scheme *sc, int n) { - pointer x; - - if(sc->no_memory) { - return sc->sink; - } - - /* Are there any cells available? */ - x=find_consecutive_cells(sc,n); - if (x == sc->NIL) { - /* If not, try gc'ing some */ - gc(sc, sc->NIL, sc->NIL); - x=find_consecutive_cells(sc,n); - if (x == sc->NIL) { - /* If there still aren't, try getting more heap */ - if (!alloc_cellseg(sc,1)) { - sc->no_memory=1; - return sc->sink; - } - } - x=find_consecutive_cells(sc,n); - if (x == sc->NIL) { - /* If all fail, report failure */ - sc->no_memory=1; - return sc->sink; - } - } - return (x); -} - -static int count_consecutive_cells(pointer x, int needed) { - int n=1; - while(cdr(x)==x+1) { - x=cdr(x); - n++; - if(n>needed) return n; - } - return n; -} - -static pointer find_consecutive_cells(scheme *sc, int n) { - pointer *pp; - int cnt; - - pp=&sc->free_cell; - while(*pp!=sc->NIL) { - cnt=count_consecutive_cells(*pp,n); - if(cnt>=n) { - pointer x=*pp; - *pp=cdr(*pp+n-1); - sc->fcells -= n; - return x; - } - pp=&cdr(*pp+cnt-1); - } - return sc->NIL; -} - -/* get new cons cell */ -pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { - pointer x = get_cell(sc,a, b); - - typeflag(x) = T_PAIR; - if(immutable) { - setimmutable(x); - } - car(x) = a; - cdr(x) = b; - return (x); -} - -/* ========== oblist implementation ========== */ - -#ifndef USE_OBJECT_LIST - -static int hash_fn(const char *key, int table_size); - -static pointer oblist_initial_value(scheme *sc) -{ - return mk_vector(sc, 461); /* probably should be bigger */ -} - -/* returns the new symbol */ -static pointer oblist_add_by_name(scheme *sc, const char *name) -{ - pointer x; - int location; - - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL; - setimmutable(car(x)); - - location = hash_fn(name, ivalue_unchecked(sc->oblist)); - set_vector_elem(sc->oblist, location, - immutable_cons(sc, x, vector_elem(sc->oblist, location))); - return x; -} - -static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) -{ - int location; - pointer x; - char *s; - - location = hash_fn(name, ivalue_unchecked(sc->oblist)); - for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { - s = symname(car(x)); - /* case-insensitive, per R5RS section 2. */ - if(stricmp(name, s) == 0) { - return car(x); - } - } - return sc->NIL; -} - -static pointer oblist_all_symbols(scheme *sc) -{ - int i; - pointer x; - pointer ob_list = sc->NIL; - - for (i = 0; i < ivalue_unchecked(sc->oblist); i++) { - for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { - ob_list = cons(sc, x, ob_list); - } - } - return ob_list; -} - -#else - -static pointer oblist_initial_value(scheme *sc) -{ - return sc->NIL; -} - -static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) -{ - pointer x; - char *s; - - for (x = sc->oblist; x != sc->NIL; x = cdr(x)) { - s = symname(car(x)); - /* case-insensitive, per R5RS section 2. */ - if(stricmp(name, s) == 0) { - return car(x); - } - } - return sc->NIL; -} - -/* returns the new symbol */ -static pointer oblist_add_by_name(scheme *sc, const char *name) -{ - pointer x; - - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL; - setimmutable(car(x)); - sc->oblist = immutable_cons(sc, x, sc->oblist); - return x; -} -static pointer oblist_all_symbols(scheme *sc) -{ - return sc->oblist; -} - -#endif - -static pointer mk_port(scheme *sc, port *p) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = T_PORT|T_ATOM; - x->_object._port=p; - return (x); -} - -pointer mk_foreign_func(scheme *sc, foreign_func f) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = (T_FOREIGN | T_ATOM); - x->_object._ff=f; - return (x); -} - -INTERFACE pointer mk_character(scheme *sc, int c) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_CHARACTER | T_ATOM); - ivalue_unchecked(x)= c; - set_integer(x); - return (x); -} - -/* get number atom (integer) */ -INTERFACE pointer mk_integer(scheme *sc, long num) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_NUMBER | T_ATOM); - ivalue_unchecked(x)= num; - set_integer(x); - return (x); -} - -INTERFACE pointer mk_real(scheme *sc, double n) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_NUMBER | T_ATOM); - rvalue_unchecked(x)= n; - set_real(x); - return (x); -} - -static pointer mk_number(scheme *sc, num n) { - if(n.is_fixnum) { - return mk_integer(sc,n.value.ivalue); - } else { - return mk_real(sc,n.value.rvalue); - } -} - -/* allocate name to string area */ -static char *store_string(scheme *sc, int len_str, const char *str, char fill) { - char *q; - - q=(char*)sc->malloc(len_str+1); - if(q==0) { - sc->no_memory=1; - return sc->strbuff; - } - if(str!=0) { - strcpy(q, str); - } else { - memset(q, fill, len_str); - q[len_str]=0; - } - return (q); -} - -/* get new string */ -INTERFACE pointer mk_string(scheme *sc, const char *str) { - return mk_counted_string(sc,str,strlen(str)); -} - -INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - strvalue(x) = store_string(sc,len,str,0); - typeflag(x) = (T_STRING | T_ATOM); - strlength(x) = len; - return (x); -} - -static pointer mk_empty_string(scheme *sc, int len, char fill) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - strvalue(x) = store_string(sc,len,0,fill); - typeflag(x) = (T_STRING | T_ATOM); - strlength(x) = len; - return (x); -} - -INTERFACE static pointer mk_vector(scheme *sc, int len) { - pointer x=get_consecutive_cells(sc,len/2+len%2+1); - typeflag(x) = (T_VECTOR | T_ATOM); - ivalue_unchecked(x)=len; - set_integer(x); - fill_vector(x,sc->NIL); - return x; -} - -INTERFACE static void fill_vector(pointer vec, pointer obj) { - int i; - int num=ivalue(vec)/2+ivalue(vec)%2; - for(i=0; iNIL) { - return (x); - } else { - x = oblist_add_by_name(sc, name); - return (x); - } -} - -INTERFACE pointer gensym(scheme *sc) { - pointer x; - char name[40]; - - for(; sc->gensym_cntgensym_cnt++) { - sprintf(name,"gensym-%ld",sc->gensym_cnt); - - /* first check oblist */ - x = oblist_find_by_name(sc, name); - - if (x != sc->NIL) { - continue; - } else { - x = oblist_add_by_name(sc, name); - return (x); - } - } - - return sc->NIL; -} - -/* make symbol or number atom from string */ -static pointer mk_atom(scheme *sc, char *q) { - char c, *p; - int has_dec_point=0; - int has_fp_exp = 0; - -#if USE_COLON_HOOK - if((p=strstr(q,"::"))!=0) { - *p=0; - return cons(sc, sc->COLON_HOOK, - cons(sc, - cons(sc, - sc->QUOTE, - cons(sc, mk_atom(sc,p+2), sc->NIL)), - cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL))); - } -#endif - - p = q; - c = *p++; - if ((c == '+') || (c == '-')) { - c = *p++; - if (c == '.') { - has_dec_point=1; - c = *p++; - } - if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - } else if (c == '.') { - has_dec_point=1; - c = *p++; - if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - } else if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - - for ( ; (c = *p) != 0; ++p) { - if (!isdigit(c)) { - if(c=='.') { - if(!has_dec_point) { - has_dec_point=1; - continue; - } - } - else if ((c == 'e') || (c == 'E')) { - if(!has_fp_exp) { - has_dec_point = 1; /* decimal point illegal - from now on */ - p++; - if ((*p == '-') || (*p == '+') || isdigit(*p)) { - continue; - } - } - } - return (mk_symbol(sc, strlwr(q))); - } - } - if(has_dec_point) { - return mk_real(sc,atof(q)); - } - return (mk_integer(sc, atol(q))); -} - -/* make constant */ -static pointer mk_sharp_const(scheme *sc, char *name) { - long x; - char tmp[256]; - - if (!strcmp(name, "t")) - return (sc->T); - else if (!strcmp(name, "f")) - return (sc->F); - else if (*name == 'o') {/* #o (octal) */ - snprintf(tmp, sizeof(tmp), "0%s", name+1); - sscanf(tmp, "%lo", &x); - return (mk_integer(sc, x)); - } else if (*name == 'd') { /* #d (decimal) */ - sscanf(name+1, "%ld", &x); - return (mk_integer(sc, x)); - } else if (*name == 'x') { /* #x (hex) */ - snprintf(tmp, sizeof(tmp), "0x%s", name+1); - sscanf(tmp, "%lx", &x); - return (mk_integer(sc, x)); - } else if (*name == 'b') { /* #b (binary) */ - x = binary_decode(name+1); - return (mk_integer(sc, x)); - } else if (*name == '\\') { /* #\w (character) */ - int c=0; - if(stricmp(name+1,"space")==0) { - c=' '; - } else if(stricmp(name+1,"newline")==0) { - c='\n'; - } else if(stricmp(name+1,"return")==0) { - c='\r'; - } else if(stricmp(name+1,"tab")==0) { - c='\t'; - } else if(name[1]=='x' && name[2]!=0) { - int c1=0; - if(sscanf(name+2,"%x",&c1)==1 && c1<256) { - c=c1; - } else { - return sc->NIL; - } -#if USE_ASCII_NAMES - } else if(is_ascii_name(name+1,&c)) { - /* nothing */ -#endif - } else if(name[2]==0) { - c=name[1]; - } else { - return sc->NIL; - } - return mk_character(sc,c); - } else - return (sc->NIL); -} - -/* ========== garbage collector ========== */ - -/*-- - * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, - * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, - * for marking. - */ -static void mark(pointer a) { - pointer t, q, p; - - t = (pointer) 0; - p = a; -E2: setmark(p); - if(is_vector(p)) { - int i; - int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2; - for(i=0; igc_verbose) { - putstr(sc, "gc..."); - } - - /* mark system globals */ - mark(sc->oblist); - mark(sc->global_env); - - /* mark current registers */ - mark(sc->args); - mark(sc->envir); - mark(sc->code); - dump_stack_mark(sc); - mark(sc->value); - mark(sc->inport); - mark(sc->save_inport); - mark(sc->outport); - mark(sc->loadport); - - /* mark variables a, b */ - mark(a); - mark(b); - - /* garbage collect */ - clrmark(sc->NIL); - sc->fcells = 0; - sc->free_cell = sc->NIL; - /* free-list is kept sorted by address so as to maintain consecutive - ranges, if possible, for use with vectors. Here we scan the cells - (which are also kept sorted by address) downwards to build the - free-list in sorted order. - */ - for (i = sc->last_cell_seg; i >= 0; i--) { - p = sc->cell_seg[i] + CELL_SEGSIZE; - while (--p >= sc->cell_seg[i]) { - if (is_mark(p)) { - clrmark(p); - } else { - /* reclaim cell */ - if (typeflag(p) != 0) { - finalize_cell(sc, p); - typeflag(p) = 0; - car(p) = sc->NIL; - } - ++sc->fcells; - cdr(p) = sc->free_cell; - sc->free_cell = p; - } - } - } - - if (sc->gc_verbose) { - char msg[80]; - sprintf(msg,"done: %ld cells were recovered.\n", sc->fcells); - putstr(sc,msg); - } -} - -static void finalize_cell(scheme *sc, pointer a) { - if(is_string(a)) { - sc->free(strvalue(a)); - } else if(is_port(a)) { - if(a->_object._port->kind&port_file - && a->_object._port->rep.stdio.closeit) { - port_close(sc,a,port_input|port_output); - } - sc->free(a->_object._port); - } -} - -/* ========== Routines for Reading ========== */ - -static int file_push(scheme *sc, const char *fname) { - FILE *fin=fopen(fname,"r"); - if(fin!=0) { - sc->file_i++; - sc->load_stack[sc->file_i].kind=port_file|port_input; - sc->load_stack[sc->file_i].rep.stdio.file=fin; - sc->load_stack[sc->file_i].rep.stdio.closeit=1; - sc->nesting_stack[sc->file_i]=0; - sc->loadport->_object._port=sc->load_stack+sc->file_i; - } - return fin!=0; -} - -static void file_pop(scheme *sc) { - sc->nesting=sc->nesting_stack[sc->file_i]; - if(sc->file_i!=0) { - port_close(sc,sc->loadport,port_input); - sc->file_i--; - sc->loadport->_object._port=sc->load_stack+sc->file_i; - if(file_interactive(sc)) { - putstr(sc,prompt); - } - } -} - -static int file_interactive(scheme *sc) { - return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin - && sc->inport->_object._port->kind&port_file; -} - -static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { - FILE *f; - char *rw; - port *pt; - if(prop==(port_input|port_output)) { - rw="a+"; - } else if(prop==port_output) { - rw="w"; - } else { - rw="r"; - } - f=fopen(fn,rw); - if(f==0) { - return 0; - } - pt=port_rep_from_file(sc,f,prop); - pt->rep.stdio.closeit=1; - return pt; -} - -static pointer port_from_filename(scheme *sc, const char *fn, int prop) { - port *pt; - pt=port_rep_from_filename(sc,fn,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static port *port_rep_from_file(scheme *sc, FILE *f, int prop) { - char *rw; - port *pt; - pt=(port*)sc->malloc(sizeof(port)); - if(pt==0) { - return 0; - } - if(prop==(port_input|port_output)) { - rw="a+"; - } else if(prop==port_output) { - rw="w"; - } else { - rw="r"; - } - pt->kind=port_file|prop; - pt->rep.stdio.file=f; - pt->rep.stdio.closeit=0; - return pt; -} - -static pointer port_from_file(scheme *sc, FILE *f, int prop) { - port *pt; - pt=port_rep_from_file(sc,f,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { - port *pt; - pt=(port*)sc->malloc(sizeof(port)); - if(pt==0) { - return 0; - } - pt->kind=port_string|prop; - pt->rep.string.start=start; - pt->rep.string.curr=start; - pt->rep.string.past_the_end=past_the_end; - return pt; -} - -static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { - port *pt; - pt=port_rep_from_string(sc,start,past_the_end,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static void port_close(scheme *sc, pointer p, int flag) { - port *pt=p->_object._port; - pt->kind&=~flag; - if((pt->kind & (port_input|port_output))==0) { - if(pt->kind&port_file) { - fclose(pt->rep.stdio.file); - } - pt->kind=port_free; - } -} - -/* get new character from input file */ -static int inchar(scheme *sc) { - int c; - port *pt; - again: - pt=sc->inport->_object._port; - c=basic_inchar(pt); - if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) { - file_pop(sc); - if(sc->nesting!=0) { - return EOF; - } else { - return '\n'; - } - goto again; - } - return c; -} - -static int basic_inchar(port *pt) { - if(pt->kind&port_file) { - return fgetc(pt->rep.stdio.file); - } else { - if(*pt->rep.string.curr==0 - || pt->rep.string.curr==pt->rep.string.past_the_end) { - return EOF; - } else { - return *pt->rep.string.curr++; - } - } -} - -/* back character to input buffer */ -static void backchar(scheme *sc, int c) { - port *pt; - if(c==EOF) return; - pt=sc->inport->_object._port; - if(pt->kind&port_file) { - ungetc(c,pt->rep.stdio.file); - } else { - if(pt->rep.string.curr!=pt->rep.string.start) { - --pt->rep.string.curr; - } - } -} - -INTERFACE void putstr(scheme *sc, const char *s) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fputs(s,pt->rep.stdio.file); - } else { - for(;*s;s++) { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=*s; - } - } - } -} - -static void putchars(scheme *sc, const char *s, int len) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fwrite(s,1,len,pt->rep.stdio.file); - } else { - for(;len;len--) { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=*s++; - } - } - } -} - -INTERFACE void putcharacter(scheme *sc, int c) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fputc(c,pt->rep.stdio.file); - } else { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=c; - } - } -} - -/* read characters up to delimiter, but cater to character constants */ -static char *readstr_upto(scheme *sc, char *delim) { - char *p = sc->strbuff; - - while (!is_one_of(delim, (*p++ = inchar(sc)))); - if(p==sc->strbuff+2 && p[-2]=='\\') { - *p=0; - } else { - backchar(sc,p[-1]); - *--p = '\0'; - } - return sc->strbuff; -} - -/* read string expression "xxx...xxx" */ -static pointer readstrexp(scheme *sc) { - char *p = sc->strbuff; - int c; - int c1=0; - enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2, st_oct3 } state=st_ok; - - for (;;) { - c=inchar(sc); - if(c==EOF || p-sc->strbuff>sizeof(sc->strbuff)-1) { - return sc->F; - } - switch(state) { - case st_ok: - switch(c) { - case '\\': - state=st_bsl; - break; - case '"': - *p=0; - return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); - default: - *p++=c; - break; - } - break; - case st_bsl: - switch(c) { - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - state=st_oct1; - c1=c-'0'; - break; - case 'x': - case 'X': - state=st_x1; - c1=0; - break; - case 'n': - *p++='\n'; - state=st_ok; - break; - case 't': - *p++='\t'; - state=st_ok; - break; - case 'r': - *p++='\r'; - state=st_ok; - break; - case '"': - *p++='"'; - state=st_ok; - break; - default: - *p++=c; - state=st_ok; - break; - } - break; - case st_x1: - case st_x2: - c=toupper(c); - if(c>='0' && c<='F') { - if(c<='9') { - c1=(c1<<4)+c-'0'; - } else { - c1=(c1<<4)+c-'A'+10; - } - if(state==st_x1) { - state=st_x2; - } else { - *p++=c1; - state=st_ok; - } - } else { - return sc->F; - } - break; - case st_oct1: - case st_oct2: - case st_oct3: - if (c < '0' || c > '7') - { - if (state==st_oct1) - return sc->F; - - *p++=c1; - backchar(sc, c); - state=st_ok; - } - else - { - c1=(c1<<3)+(c-'0'); - switch (state) - { - case st_oct1: - state=st_oct2; - break; - case st_oct2: - state=st_oct3; - break; - default: - *p++=c1; - state=st_ok; - break; - } - } - break; - - } - } -} - -/* check c is in chars */ -static INLINE int is_one_of(char *s, int c) { - if(c==EOF) return 1; - while (*s) - if (*s++ == c) - return (1); - return (0); -} - -/* skip white characters */ -static INLINE void skipspace(scheme *sc) { - int c; - while (isspace(c=inchar(sc))) - ; - if(c!=EOF) { - backchar(sc,c); - } -} - -/* get token */ -static int token(scheme *sc) { - int c; - skipspace(sc); - switch (c=inchar(sc)) { - case EOF: - return (TOK_EOF); - case '[': - case '(': - return (TOK_LPAREN); - case ']': - case ')': - return (TOK_RPAREN); - case '.': - c=inchar(sc); - if(is_one_of(" \n\t",c)) { - return (TOK_DOT); - } else { - backchar(sc,c); - backchar(sc,'.'); - return TOK_ATOM; - } - case '\'': - return (TOK_QUOTE); - case ';': - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - return (token(sc)); - case '"': - return (TOK_DQUOTE); - case BACKQUOTE: - return (TOK_BQUOTE); - case ',': - if ((c=inchar(sc)) == '@') { - return (TOK_ATMARK); - } else { - backchar(sc,c); - return (TOK_COMMA); - } - case '#': - c=inchar(sc); - if (c == '(') { - return (TOK_VEC); - } else if(c == '!') { - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - return (token(sc)); - } else { - backchar(sc,c); - if(is_one_of(" tfodxb\\",c)) { - return TOK_SHARP_CONST; - } else { - return (TOK_SHARP); - } - } - default: - backchar(sc,c); - return (TOK_ATOM); - } -} - -/* ========== Routines for Printing ========== */ -#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) - -static void printslashstring(scheme *sc, char *p, int len) { - int i; - unsigned char *s=(unsigned char*)p; - putcharacter(sc,'"'); - for ( i=0; iNIL) { - p = "()"; - } else if (l == sc->T) { - p = "#t"; - } else if (l == sc->F) { - p = "#f"; - } else if (l == sc->EOF_OBJ) { - p = "#"; - } else if (is_port(l)) { - p = sc->strbuff; - strcpy(p, "#"); - } else if (is_number(l)) { - p = sc->strbuff; - if(is_integer(l)) { - sprintf(p, "%ld", ivalue_unchecked(l)); - } else { - sprintf(p, "%.10g", rvalue_unchecked(l)); - } - } else if (is_string(l)) { - if (!f) { - p = strvalue(l); - } else { /* Hack, uses the fact that printing is needed */ - *pp=sc->strbuff; - *plen=0; - printslashstring(sc, strvalue(l), strlength(l)); - return; - } - } else if (is_character(l)) { - int c=charvalue(l); - p = sc->strbuff; - if (!f) { - p[0]=c; - p[1]=0; - } else { - switch(c) { - case ' ': - sprintf(p,"#\\space"); break; - case '\n': - sprintf(p,"#\\newline"); break; - case '\r': - sprintf(p,"#\\return"); break; - case '\t': - sprintf(p,"#\\tab"); break; - default: -#if USE_ASCII_NAMES - if(c==127) { - strcpy(p,"#\\del"); break; - } else if(c<32) { - strcpy(p,"#\\"); strcat(p,charnames[c]); break; - } -#else - if(c<32) { - sprintf(p,"#\\x%x",c); break; - } -#endif - sprintf(p,"#\\%c",c); break; - } - } - } else if (is_symbol(l)) { - p = symname(l); - } else if (is_proc(l)) { - p = sc->strbuff; - sprintf(p, "#<%s PROCEDURE %ld>", procname(l),procnum(l)); - } else if (is_macro(l)) { - p = "#"; - } else if (is_closure(l)) { - p = "#"; - } else if (is_promise(l)) { - p = "#"; - } else if (is_foreign(l)) { - p = sc->strbuff; - sprintf(p, "#", procnum(l)); - } else if (is_continuation(l)) { - p = "#"; - } else { - p = "#"; - } - *pp=p; - *plen=strlen(p); -} -/* ========== Routines for Evaluation Cycle ========== */ - -/* make closure. c is code. e is environment */ -static pointer mk_closure(scheme *sc, pointer c, pointer e) { - pointer x = get_cell(sc, c, e); - - typeflag(x) = T_CLOSURE; - car(x) = c; - cdr(x) = e; - return (x); -} - -/* make continuation. */ -static pointer mk_continuation(scheme *sc, pointer d) { - pointer x = get_cell(sc, sc->NIL, d); - - typeflag(x) = T_CONTINUATION; - cont_dump(x) = d; - return (x); -} - -static pointer list_star(scheme *sc, pointer d) { - pointer p, q; - if(cdr(d)==sc->NIL) { - return car(d); - } - p=cons(sc,car(d),cdr(d)); - q=p; - while(cdr(cdr(p))!=sc->NIL) { - d=cons(sc,car(p),cdr(p)); - if(cdr(cdr(p))!=sc->NIL) { - p=cdr(d); - } - } - cdr(p)=car(cdr(p)); - return q; -} - -/* reverse list -- produce new list */ -static pointer reverse(scheme *sc, pointer a) { -/* a must be checked by gc */ - pointer p = sc->NIL; - - for ( ; is_pair(a); a = cdr(a)) { - p = cons(sc, car(a), p); - } - return (p); -} - -/* reverse list --- in-place */ -static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { - pointer p = list, result = term, q; - - while (p != sc->NIL) { - q = cdr(p); - cdr(p) = result; - result = p; - p = q; - } - return (result); -} - -/* append list -- produce new list */ -static pointer append(scheme *sc, pointer a, pointer b) { - pointer p = b, q; - - if (a != sc->NIL) { - a = reverse(sc, a); - while (a != sc->NIL) { - q = cdr(a); - cdr(a) = p; - p = a; - a = q; - } - } - return (p); -} - -/* equivalence of atoms */ -static int eqv(pointer a, pointer b) { - if (is_string(a)) { - if (is_string(b)) - return (strvalue(a) == strvalue(b)); - else - return (0); - } else if (is_number(a)) { - if (is_number(b)) - return num_eq(nvalue(a),nvalue(b)); - else - return (0); - } else if (is_character(a)) { - if (is_character(b)) - return charvalue(a)==charvalue(b); - else - return (0); - } else if (is_port(a)) { - if (is_port(b)) - return a==b; - else - return (0); - } else if (is_proc(a)) { - if (is_proc(b)) - return procnum(a)==procnum(b); - else - return (0); - } else { - return (a == b); - } -} - -/* true or false value macro */ -/* () is #t in R5RS */ -#define is_true(p) ((p) != sc->F) -#define is_false(p) ((p) == sc->F) - -/* ========== Environment implementation ========== */ - -#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) - -static int hash_fn(const char *key, int table_size) -{ - unsigned int hashed = 0; - const char *c; - int bits_per_int = sizeof(unsigned int)*8; - - for (c = key; *c; c++) { - /* letters have about 5 bits in them */ - hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); - hashed ^= *c; - } - return hashed % table_size; -} -#endif - -#ifndef USE_ALIST_ENV - -/* - * In this implementation, each frame of the environment may be - * a hash table: a vector of alists hashed by variable name. - * In practice, we use a vector only for the initial frame; - * subsequent frames are too small and transient for the lookup - * speed to out-weigh the cost of making a new vector. - */ - -static void new_frame_in_env(scheme *sc, pointer old_env) -{ - pointer new_frame; - - /* The interaction-environment has about 300 variables in it. */ - if (old_env == sc->NIL) { - new_frame = mk_vector(sc, 461); - } else { - new_frame = sc->NIL; - } - - sc->envir = immutable_cons(sc, new_frame, old_env); - setenvironment(sc->envir); -} - -static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, - pointer variable, pointer value) -{ - pointer slot = immutable_cons(sc, variable, value); - - if (is_vector(car(env))) { - int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); - - set_vector_elem(car(env), location, - immutable_cons(sc, slot, vector_elem(car(env), location))); - } else { - car(env) = immutable_cons(sc, slot, car(env)); - } -} - -static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) -{ - pointer x,y; - int location; - - for (x = env; x != sc->NIL; x = cdr(x)) { - if (is_vector(car(x))) { - location = hash_fn(symname(hdl), ivalue_unchecked(car(x))); - y = vector_elem(car(x), location); - } else { - y = car(x); - } - for ( ; y != sc->NIL; y = cdr(y)) { - if (caar(y) == hdl) { - break; - } - } - if (y != sc->NIL) { - break; - } - if(!all) { - return sc->NIL; - } - } - if (x != sc->NIL) { - return car(y); - } - return sc->NIL; -} - -#else /* USE_ALIST_ENV */ - -static INLINE void new_frame_in_env(scheme *sc, pointer old_env) -{ - sc->envir = immutable_cons(sc, sc->NIL, old_env); - setenvironment(sc->envir); -} - -static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, - pointer variable, pointer value) -{ - car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); -} - -static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) -{ - pointer x,y; - for (x = env; x != sc->NIL; x = cdr(x)) { - for (y = car(x); y != sc->NIL; y = cdr(y)) { - if (caar(y) == hdl) { - break; - } - } - if (y != sc->NIL) { - break; - } - if(!all) { - return sc->NIL; - } - } - if (x != sc->NIL) { - return car(y); - } - return sc->NIL; -} - -#endif /* USE_ALIST_ENV else */ - -static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) -{ - new_slot_spec_in_env(sc, sc->envir, variable, value); -} - -static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) -{ - cdr(slot) = value; -} - -static INLINE pointer slot_value_in_env(pointer slot) -{ - return cdr(slot); -} - -/* ========== Evaluation Cycle ========== */ - - -static pointer _Error_1(scheme *sc, const char *s, pointer a) { -#if USE_ERROR_HOOK - pointer x; - pointer hdl=sc->ERROR_HOOK; - - x=find_slot_in_env(sc,sc->envir,hdl,1); - if (x != sc->NIL) { - if(a!=0) { - sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL); - } else { - sc->code = sc->NIL; - } - sc->code = cons(sc, mk_string(sc, (s)), sc->code); - setimmutable(car(sc->code)); - sc->code = cons(sc, slot_value_in_env(x), sc->code); - sc->op = (int)OP_EVAL; - return sc->T; - } -#endif - - if(a!=0) { - sc->args = cons(sc, (a), sc->NIL); - } else { - sc->args = sc->NIL; - } - sc->args = cons(sc, mk_string(sc, (s)), sc->args); - setimmutable(car(sc->args)); - sc->op = (int)OP_ERR0; - return sc->T; -} -#define Error_1(sc,s, a) return _Error_1(sc,s,a) -#define Error_0(sc,s) return _Error_1(sc,s,0) - -/* Too small to turn into function */ -# define BEGIN do { -# define END } while (0) -#define s_goto(sc,a) BEGIN \ - sc->op = (int)(a); \ - return sc->T; END - -#define s_return(sc,a) return _s_return(sc,a) - -#ifndef USE_SCHEME_STACK - -/* this structure holds all the interpreter's registers */ -struct dump_stack_frame { - enum scheme_opcodes op; - pointer args; - pointer envir; - pointer code; -}; - -#define STACK_GROWTH 3 - -static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) -{ - int nframes = (int)sc->dump; - struct dump_stack_frame *next_frame; - - /* enough room for the next frame? */ - if (nframes >= sc->dump_size) { - sc->dump_size += STACK_GROWTH; - /* alas there is no sc->realloc */ - sc->dump_base = realloc(sc->dump_base, - sizeof(struct dump_stack_frame) * sc->dump_size); - } - next_frame = (struct dump_stack_frame *)sc->dump_base + nframes; - next_frame->op = op; - next_frame->args = args; - next_frame->envir = sc->envir; - next_frame->code = code; - sc->dump = (pointer)(nframes+1); -} - -static pointer _s_return(scheme *sc, pointer a) -{ - int nframes = (int)sc->dump; - struct dump_stack_frame *frame; - - sc->value = (a); - if (nframes <= 0) { - return sc->NIL; - } - nframes--; - frame = (struct dump_stack_frame *)sc->dump_base + nframes; - sc->op = frame->op; - sc->args = frame->args; - sc->envir = frame->envir; - sc->code = frame->code; - sc->dump = (pointer)nframes; - return sc->T; -} - -static INLINE void dump_stack_reset(scheme *sc) -{ - /* in this implementation, sc->dump is the number of frames on the stack */ - sc->dump = (pointer)0; -} - -static INLINE void dump_stack_initialize(scheme *sc) -{ - sc->dump_size = 0; - sc->dump_base = NULL; - dump_stack_reset(sc); -} - -static void dump_stack_free(scheme *sc) -{ - free(sc->dump_base); - sc->dump_base = NULL; - sc->dump = (pointer)0; - sc->dump_size = 0; -} - -static INLINE void dump_stack_mark(scheme *sc) -{ - int nframes = (int)sc->dump; - int i; - for(i=0; idump_base + i; - mark(frame->args); - mark(frame->envir); - mark(frame->code); - } -} - -#else - -static INLINE void dump_stack_reset(scheme *sc) -{ - sc->dump = sc->NIL; -} - -static INLINE void dump_stack_initialize(scheme *sc) -{ - dump_stack_reset(sc); -} - -static void dump_stack_free(scheme *sc) -{ - sc->dump = sc->NIL; -} - -static pointer _s_return(scheme *sc, pointer a) { - sc->value = (a); - if(sc->dump==sc->NIL) return sc->NIL; - sc->op = ivalue(car(sc->dump)); - sc->args = cadr(sc->dump); - sc->envir = caddr(sc->dump); - sc->code = cadddr(sc->dump); - sc->dump = cddddr(sc->dump); - return sc->T; -} - -static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { - sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); - sc->dump = cons(sc, (args), sc->dump); - sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); -} - -static INLINE void dump_stack_mark(scheme *sc) -{ - mark(sc->dump); -} -#endif - -#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) - -static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - - switch (op) { - case OP_LOAD: /* load */ - if(file_interactive(sc)) { - fprintf(sc->outport->_object._port->rep.stdio.file, - "Loading %s...\n", strvalue(car(sc->args))); - } - if (!file_push(sc,strvalue(car(sc->args)))) { - Error_1(sc,"unable to open", car(sc->args)); - } - s_goto(sc,OP_T0LVL); - - case OP_T0LVL: /* top level */ - if(file_interactive(sc)) { - putstr(sc,"\n"); - } - sc->nesting=0; - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->save_inport=sc->inport; - sc->inport = sc->loadport; - s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); - s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); - s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); - if (file_interactive(sc)) { - putstr(sc,prompt); - } - s_goto(sc,OP_READ_INTERNAL); - - case OP_T1LVL: /* top level */ - sc->code = sc->value; - sc->inport=sc->save_inport; - s_goto(sc,OP_EVAL); - - case OP_READ_INTERNAL: /* internal read */ - sc->tok = token(sc); - if(sc->tok==TOK_EOF) { - if(sc->inport==sc->loadport) { - sc->args=sc->NIL; - s_goto(sc,OP_QUIT); - } else { - s_return(sc,sc->EOF_OBJ); - } - } - s_goto(sc,OP_RDSEXPR); - - case OP_GENSYM: - s_return(sc, gensym(sc)); - - case OP_VALUEPRINT: /* print evaluation result */ - /* OP_VALUEPRINT is always pushed, because when changing from - non-interactive to interactive mode, it needs to be - already on the stack */ - if(sc->tracing) { - putstr(sc,"\nGives: "); - } - if(file_interactive(sc)) { - sc->print_flag = 1; - sc->args = sc->value; - s_goto(sc,OP_P0LIST); - } else { - s_return(sc,sc->value); - } - - case OP_EVAL: /* main part of evaluation */ -#if USE_TRACING - if(sc->tracing) { - /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ - s_save(sc,OP_REAL_EVAL,sc->args,sc->code); - sc->args=sc->code; - putstr(sc,"\nEval: "); - s_goto(sc,OP_P0LIST); - } - /* fall through */ - case OP_REAL_EVAL: -#endif - if (is_symbol(sc->code)) { /* symbol */ - x=find_slot_in_env(sc,sc->envir,sc->code,1); - if (x != sc->NIL) { - s_return(sc,slot_value_in_env(x)); - } else { - Error_1(sc,"eval: unbound variable:", sc->code); - } - } else if (is_pair(sc->code)) { - if (is_syntax(x = car(sc->code))) { /* SYNTAX */ - sc->code = cdr(sc->code); - s_goto(sc,syntaxnum(x)); - } else {/* first, eval top element and eval arguments */ - s_save(sc,OP_E0ARGS, sc->NIL, sc->code); - /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - } - } else { - s_return(sc,sc->code); - } - - case OP_E0ARGS: /* eval arguments */ - if (is_macro(sc->value)) { /* macro expansion */ - s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); - sc->args = cons(sc,sc->code, sc->NIL); - sc->code = sc->value; - s_goto(sc,OP_APPLY); - } else { - sc->code = cdr(sc->code); - s_goto(sc,OP_E1ARGS); - } - - case OP_E1ARGS: /* eval arguments */ - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); - sc->code = car(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_goto(sc,OP_APPLY); - } - -#if USE_TRACING - case OP_TRACING: { - int tr=sc->tracing; - sc->tracing=ivalue(car(sc->args)); - s_return(sc,mk_integer(sc,tr)); - } -#endif - - case OP_APPLY: /* apply 'code' to 'args' */ -#if USE_TRACING - if(sc->tracing) { - s_save(sc,OP_REAL_APPLY,sc->args,sc->code); - sc->print_flag = 1; - /* sc->args=cons(sc,sc->code,sc->args);*/ - putstr(sc,"\nApply to: "); - s_goto(sc,OP_P0LIST); - } - /* fall through */ - case OP_REAL_APPLY: -#endif - if (is_proc(sc->code)) { - s_goto(sc,procnum(sc->code)); /* PROCEDURE */ - } else if (is_foreign(sc->code)) { - x=sc->code->_object._ff(sc,sc->args); - s_return(sc,x); - } else if (is_closure(sc->code) || is_macro(sc->code) - || is_promise(sc->code)) { /* CLOSURE */ - /* Should not accept promise */ - /* make environment */ - new_frame_in_env(sc, closure_env(sc->code)); - for (x = car(closure_code(sc->code)), y = sc->args; - is_pair(x); x = cdr(x), y = cdr(y)) { - if (y == sc->NIL) { - Error_0(sc,"not enough arguments"); - } else { - new_slot_in_env(sc, car(x), car(y)); - } - } - if (x == sc->NIL) { - /*-- - * if (y != sc->NIL) { - * Error_0(sc,"too many arguments"); - * } - */ - } else if (is_symbol(x)) - new_slot_in_env(sc, x, y); - else { - Error_1(sc,"syntax error in closure: not a symbol:", x); - } - sc->code = cdr(closure_code(sc->code)); - sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); - } else if (is_continuation(sc->code)) { /* CONTINUATION */ - sc->dump = cont_dump(sc->code); - s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); - } else { - Error_0(sc,"illegal function"); - } - - case OP_DOMACRO: /* do macro */ - sc->code = sc->value; - s_goto(sc,OP_EVAL); - - case OP_LAMBDA: /* lambda */ - case OP_LAMBDA2: /* fn */ - s_return(sc,mk_closure(sc, sc->code, sc->envir)); - - case OP_MKCLOSURE: /* make-closure */ - x=car(sc->args); - if(car(x)==sc->LAMBDA) { - x=cdr(x); - } - if(cdr(sc->args)==sc->NIL) { - y=sc->envir; - } else { - y=cadr(sc->args); - } - s_return(sc,mk_closure(sc, x, y)); - - case OP_QUOTE: /* quote */ - x=car(sc->code); - s_return(sc,car(sc->code)); - - case OP_DEF0: /* define */ - if(is_immutable(car(sc->code))) - Error_1(sc,"define: unable to alter immutable", car(sc->code)); - - if (is_pair(car(sc->code))) { - x = caar(sc->code); - sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); - } else { - x = car(sc->code); - sc->code = cadr(sc->code); - } - if (!is_symbol(x)) { - Error_0(sc,"variable is not a symbol"); - } - s_save(sc,OP_DEF1, sc->NIL, x); - s_goto(sc,OP_EVAL); - - case OP_DEF1: /* define */ - x=find_slot_in_env(sc,sc->envir,sc->code,0); - if (x != sc->NIL) { - set_slot_in_env(sc, x, sc->value); - } else { - new_slot_in_env(sc, sc->code, sc->value); - } - s_return(sc,sc->code); - - - case OP_DEFP: /* defined? */ - x=sc->envir; - if(cdr(sc->args)!=sc->NIL) { - x=cadr(sc->args); - } - s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); - - case OP_SET0: /* set! */ - if(is_immutable(car(sc->code))) - Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); - s_save(sc,OP_SET1, sc->NIL, car(sc->code)); - sc->code = cadr(sc->code); - s_goto(sc,OP_EVAL); - - case OP_SET1: /* set! */ - y=find_slot_in_env(sc,sc->envir,sc->code,1); - if (y != sc->NIL) { - set_slot_in_env(sc, y, sc->value); - s_return(sc,sc->value); - } else { - Error_1(sc,"set!: unbound variable:", sc->code); - } - - - case OP_BEGIN: /* begin */ - if (!is_pair(sc->code)) { - s_return(sc,sc->code); - } - if (cdr(sc->code) != sc->NIL) { - s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); - } - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_IF0: /* if */ - s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_IF1: /* if */ - if (is_true(sc->value)) - sc->code = car(sc->code); - else - sc->code = cadr(sc->code); /* (if #f 1) ==> () because - * car(sc->NIL) = sc->NIL */ - s_goto(sc,OP_EVAL); - - case OP_LET0: /* let */ - sc->args = sc->NIL; - sc->value = sc->code; - sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); - s_goto(sc,OP_LET1); - - case OP_LET1: /* let (calculate parameters) */ - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_LET1, sc->args, cdr(sc->code)); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_goto(sc,OP_LET2); - } - - case OP_LET2: /* let */ - new_frame_in_env(sc, sc->envir); - for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; - y != sc->NIL; x = cdr(x), y = cdr(y)) { - new_slot_in_env(sc, caar(x), car(y)); - } - if (is_symbol(car(sc->code))) { /* named let */ - for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { - - sc->args = cons(sc, caar(x), sc->args); - } - x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); - new_slot_in_env(sc, car(sc->code), x); - sc->code = cddr(sc->code); - sc->args = sc->NIL; - } else { - sc->code = cdr(sc->code); - sc->args = sc->NIL; - } - s_goto(sc,OP_BEGIN); - - case OP_LET0AST: /* let* */ - if (car(sc->code) == sc->NIL) { - new_frame_in_env(sc, sc->envir); - sc->code = cdr(sc->code); - s_goto(sc,OP_BEGIN); - } - s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); - sc->code = cadaar(sc->code); - s_goto(sc,OP_EVAL); - - case OP_LET1AST: /* let* (make new frame) */ - new_frame_in_env(sc, sc->envir); - s_goto(sc,OP_LET2AST); - - case OP_LET2AST: /* let* (calculate parameters) */ - new_slot_in_env(sc, caar(sc->code), sc->value); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_LET2AST, sc->args, sc->code); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_EVAL); - } else { /* end */ - sc->code = sc->args; - sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); - } - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - - switch (op) { - case OP_LET0REC: /* letrec */ - new_frame_in_env(sc, sc->envir); - sc->args = sc->NIL; - sc->value = sc->code; - sc->code = car(sc->code); - s_goto(sc,OP_LET1REC); - - case OP_LET1REC: /* letrec (calculate parameters) */ - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_goto(sc,OP_LET2REC); - } - - case OP_LET2REC: /* letrec */ - for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { - new_slot_in_env(sc, caar(x), car(y)); - } - sc->code = cdr(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); - - case OP_COND0: /* cond */ - if (!is_pair(sc->code)) { - Error_0(sc,"syntax error in cond"); - } - s_save(sc,OP_COND1, sc->NIL, sc->code); - sc->code = caar(sc->code); - s_goto(sc,OP_EVAL); - - case OP_COND1: /* cond */ - if (is_true(sc->value)) { - if ((sc->code = cdar(sc->code)) == sc->NIL) { - s_return(sc,sc->value); - } - if(car(sc->code)==sc->FEED_TO) { - if(!is_pair(cdr(sc->code))) { - Error_0(sc,"syntax error in cond"); - } - x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); - sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); - s_goto(sc,OP_EVAL); - } - s_goto(sc,OP_BEGIN); - } else { - if ((sc->code = cdr(sc->code)) == sc->NIL) { - s_return(sc,sc->NIL); - } else { - s_save(sc,OP_COND1, sc->NIL, sc->code); - sc->code = caar(sc->code); - s_goto(sc,OP_EVAL); - } - } - - case OP_DELAY: /* delay */ - x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); - typeflag(x)=T_PROMISE; - s_return(sc,x); - - case OP_AND0: /* and */ - if (sc->code == sc->NIL) { - s_return(sc,sc->T); - } - s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_AND1: /* and */ - if (is_false(sc->value)) { - s_return(sc,sc->value); - } else if (sc->code == sc->NIL) { - s_return(sc,sc->value); - } else { - s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - } - - case OP_OR0: /* or */ - if (sc->code == sc->NIL) { - s_return(sc,sc->F); - } - s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_OR1: /* or */ - if (is_true(sc->value)) { - s_return(sc,sc->value); - } else if (sc->code == sc->NIL) { - s_return(sc,sc->value); - } else { - s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - } - - case OP_C0STREAM: /* cons-stream */ - s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_C1STREAM: /* cons-stream */ - sc->args = sc->value; /* save sc->value to register sc->args for gc */ - x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); - typeflag(x)=T_PROMISE; - s_return(sc,cons(sc, sc->args, x)); - - case OP_MACRO0: /* macro */ - if (is_pair(car(sc->code))) { - x = caar(sc->code); - sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); - } else { - x = car(sc->code); - sc->code = cadr(sc->code); - } - if (!is_symbol(x)) { - Error_0(sc,"variable is not a symbol"); - } - s_save(sc,OP_MACRO1, sc->NIL, x); - s_goto(sc,OP_EVAL); - - case OP_MACRO1: /* macro */ - typeflag(sc->value) = T_MACRO; - x = find_slot_in_env(sc, sc->envir, sc->code, 0); - if (x != sc->NIL) { - set_slot_in_env(sc, x, sc->value); - } else { - new_slot_in_env(sc, sc->code, sc->value); - } - s_return(sc,sc->code); - - case OP_CASE0: /* case */ - s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_CASE1: /* case */ - for (x = sc->code; x != sc->NIL; x = cdr(x)) { - if (!is_pair(y = caar(x))) { - break; - } - for ( ; y != sc->NIL; y = cdr(y)) { - if (eqv(car(y), sc->value)) { - break; - } - } - if (y != sc->NIL) { - break; - } - } - if (x != sc->NIL) { - if (is_pair(caar(x))) { - sc->code = cdar(x); - s_goto(sc,OP_BEGIN); - } else {/* else */ - s_save(sc,OP_CASE2, sc->NIL, cdar(x)); - sc->code = caar(x); - s_goto(sc,OP_EVAL); - } - } else { - s_return(sc,sc->NIL); - } - - case OP_CASE2: /* case */ - if (is_true(sc->value)) { - s_goto(sc,OP_BEGIN); - } else { - s_return(sc,sc->NIL); - } - - case OP_PAPPLY: /* apply */ - sc->code = car(sc->args); - sc->args = list_star(sc,cdr(sc->args)); - /*sc->args = cadr(sc->args);*/ - s_goto(sc,OP_APPLY); - - case OP_PEVAL: /* eval */ - if(cdr(sc->args)!=sc->NIL) { - sc->envir=cadr(sc->args); - } - sc->code = car(sc->args); - s_goto(sc,OP_EVAL); - - case OP_CONTINUATION: /* call-with-current-continuation */ - sc->code = car(sc->args); - sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); - s_goto(sc,OP_APPLY); - - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; -#if USE_MATH - double dd; -#endif - - switch (op) { -#if USE_MATH - case OP_INEX2EX: /* inexact->exact */ - x=car(sc->args); - if(is_integer(x)) { - s_return(sc,x); - } else if(modf(rvalue_unchecked(x),&dd)==0.0) { - s_return(sc,mk_integer(sc,ivalue(x))); - } else { - Error_1(sc,"inexact->exact: not integral:",x); - } - - case OP_EXP: - x=car(sc->args); - s_return(sc, mk_real(sc, exp(rvalue(x)))); - - case OP_LOG: - x=car(sc->args); - s_return(sc, mk_real(sc, log(rvalue(x)))); - - case OP_SIN: - x=car(sc->args); - s_return(sc, mk_real(sc, sin(rvalue(x)))); - - case OP_COS: - x=car(sc->args); - s_return(sc, mk_real(sc, cos(rvalue(x)))); - - case OP_TAN: - x=car(sc->args); - s_return(sc, mk_real(sc, tan(rvalue(x)))); - - case OP_ASIN: - x=car(sc->args); - s_return(sc, mk_real(sc, asin(rvalue(x)))); - - case OP_ACOS: - x=car(sc->args); - s_return(sc, mk_real(sc, acos(rvalue(x)))); - - case OP_ATAN: - x=car(sc->args); - if(cdr(sc->args)==sc->NIL) { - s_return(sc, mk_real(sc, atan(rvalue(x)))); - } else { - pointer y=cadr(sc->args); - s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); - } - - case OP_SQRT: - x=car(sc->args); - s_return(sc, mk_real(sc, sqrt(rvalue(x)))); - - case OP_EXPT: - x=car(sc->args); - if(cdr(sc->args)==sc->NIL) { - Error_0(sc,"expt: needs two arguments"); - } else { - pointer y=cadr(sc->args); - s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y)))); - } - - case OP_FLOOR: - x=car(sc->args); - s_return(sc, mk_real(sc, floor(rvalue(x)))); - - case OP_CEILING: - x=car(sc->args); - s_return(sc, mk_real(sc, ceil(rvalue(x)))); - - case OP_TRUNCATE : { - double rvalue_of_x ; - x=car(sc->args); - rvalue_of_x = rvalue(x) ; - if (rvalue_of_x > 0) { - s_return(sc, mk_real(sc, floor(rvalue_of_x))); - } else { - s_return(sc, mk_real(sc, ceil(rvalue_of_x))); - } - } - - case OP_ROUND: - x=car(sc->args); - s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); -#endif - - case OP_ADD: /* + */ - v=num_zero; - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - v=num_add(v,nvalue(car(x))); - } - s_return(sc,mk_number(sc, v)); - - case OP_MUL: /* * */ - v=num_one; - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - v=num_mul(v,nvalue(car(x))); - } - s_return(sc,mk_number(sc, v)); - - case OP_SUB: /* - */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_zero; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - v=num_sub(v,nvalue(car(x))); - } - s_return(sc,mk_number(sc, v)); - - case OP_DIV: /* / */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_one; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - if (!is_zero_double(rvalue(car(x)))) - v=num_div(v,nvalue(car(x))); - else { - Error_0(sc,"/: division by zero"); - } - } - s_return(sc,mk_number(sc, v)); - - case OP_INTDIV: /* quotient */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_one; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - if (ivalue(car(x)) != 0) - v=num_intdiv(v,nvalue(car(x))); - else { - Error_0(sc,"quotient: division by zero"); - } - } - s_return(sc,mk_number(sc, v)); - - case OP_REM: /* remainder */ - v = nvalue(car(sc->args)); - if (ivalue(cadr(sc->args)) != 0) - v=num_rem(v,nvalue(cadr(sc->args))); - else { - Error_0(sc,"remainder: division by zero"); - } - s_return(sc,mk_number(sc, v)); - - case OP_MOD: /* modulo */ - v = nvalue(car(sc->args)); - if (ivalue(cadr(sc->args)) != 0) - v=num_mod(v,nvalue(cadr(sc->args))); - else { - Error_0(sc,"modulo: division by zero"); - } - s_return(sc,mk_number(sc, v)); - - case OP_CAR: /* car */ - s_return(sc,caar(sc->args)); - - case OP_CDR: /* cdr */ - s_return(sc,cdar(sc->args)); - - case OP_CONS: /* cons */ - cdr(sc->args) = cadr(sc->args); - s_return(sc,sc->args); - - case OP_SETCAR: /* set-car! */ - if(!is_immutable(car(sc->args))) { - caar(sc->args) = cadr(sc->args); - s_return(sc,car(sc->args)); - } else { - Error_0(sc,"set-car!: unable to alter immutable pair"); - } - - case OP_SETCDR: /* set-cdr! */ - if(!is_immutable(car(sc->args))) { - cdar(sc->args) = cadr(sc->args); - s_return(sc,car(sc->args)); - } else { - Error_0(sc,"set-cdr!: unable to alter immutable pair"); - } - - case OP_CHAR2INT: { /* char->integer */ - char c; - c=(char)ivalue(car(sc->args)); - s_return(sc,mk_integer(sc,(unsigned char)c)); - } - - case OP_INT2CHAR: { /* integer->char */ - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - s_return(sc,mk_character(sc,(char)c)); - } - - case OP_CHARUPCASE: { - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - c=toupper(c); - s_return(sc,mk_character(sc,(char)c)); - } - - case OP_CHARDNCASE: { - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - c=tolower(c); - s_return(sc,mk_character(sc,(char)c)); - } - - case OP_STR2SYM: /* string->symbol */ - s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); - - case OP_STR2ATOM: /* string->atom */ { - char *s=strvalue(car(sc->args)); - if(*s=='#') { - s_return(sc, mk_sharp_const(sc, s+1)); - } else { - s_return(sc, mk_atom(sc, s)); - } - } - - case OP_SYM2STR: /* symbol->string */ - x=mk_string(sc,symname(car(sc->args))); - setimmutable(x); - s_return(sc,x); - case OP_ATOM2STR: /* atom->string */ - x=car(sc->args); - if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { - char *p; - int len; - atom2str(sc,x,0,&p,&len); - s_return(sc,mk_counted_string(sc,p,len)); - } else { - Error_1(sc, "atom->string: not an atom:", x); - } - - case OP_MKSTRING: { /* make-string */ - int fill=' '; - int len; - - len=ivalue(car(sc->args)); - - if(cdr(sc->args)!=sc->NIL) { - fill=charvalue(cadr(sc->args)); - } - s_return(sc,mk_empty_string(sc,len,(char)fill)); - } - - case OP_STRLEN: /* string-length */ - s_return(sc,mk_integer(sc,strlength(car(sc->args)))); - - case OP_STRREF: { /* string-ref */ - char *str; - int index; - - str=strvalue(car(sc->args)); - - index=ivalue(cadr(sc->args)); - - if(index>=strlength(car(sc->args))) { - Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); - } - - s_return(sc,mk_character(sc,((unsigned char*)str)[index])); - } - - case OP_STRSET: { /* string-set! */ - char *str; - int index; - int c; - - if(is_immutable(car(sc->args))) { - Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args)); - } - str=strvalue(car(sc->args)); - - index=ivalue(cadr(sc->args)); - if(index>=strlength(car(sc->args))) { - Error_1(sc,"string-set!: out of bounds:",cadr(sc->args)); - } - - c=charvalue(caddr(sc->args)); - - str[index]=(char)c; - s_return(sc,car(sc->args)); - } - - case OP_STRAPPEND: { /* string-append */ - /* in 1.29 string-append was in Scheme in init.scm but was too slow */ - int len = 0; - pointer newstr; - char *pos; - - /* compute needed length for new string */ - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - len += strlength(car(x)); - } - newstr = mk_empty_string(sc, len, ' '); - /* store the contents of the argument strings into the new string */ - for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; - pos += strlength(car(x)), x = cdr(x)) { - memcpy(pos, strvalue(car(x)), strlength(car(x))); - } - s_return(sc, newstr); - } - - case OP_SUBSTR: { /* substring */ - char *str; - int index0; - int index1; - int len; - - str=strvalue(car(sc->args)); - - index0=ivalue(cadr(sc->args)); - - if(index0>strlength(car(sc->args))) { - Error_1(sc,"substring: start out of bounds:",cadr(sc->args)); - } - - if(cddr(sc->args)!=sc->NIL) { - index1=ivalue(caddr(sc->args)); - if(index1>strlength(car(sc->args)) || index1args)); - } - } else { - index1=strlength(car(sc->args)); - } - - len=index1-index0; - x=mk_empty_string(sc,len,' '); - memcpy(strvalue(x),str+index0,len); - strvalue(x)[len]=0; - - s_return(sc,x); - } - - case OP_VECTOR: { /* vector */ - int i; - pointer vec; - int len=list_length(sc,sc->args); - if(len<0) { - Error_1(sc,"vector: not a proper list:",sc->args); - } - vec=mk_vector(sc,len); - for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { - set_vector_elem(vec,i,car(x)); - } - s_return(sc,vec); - } - - case OP_MKVECTOR: { /* make-vector */ - pointer fill=sc->NIL; - int len; - pointer vec; - - len=ivalue(car(sc->args)); - - if(cdr(sc->args)!=sc->NIL) { - fill=cadr(sc->args); - } - vec=mk_vector(sc,len); - if(fill!=sc->NIL) { - fill_vector(vec,fill); - } - s_return(sc,vec); - } - - case OP_VECLEN: /* vector-length */ - s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); - - case OP_VECREF: { /* vector-ref */ - int index; - - index=ivalue(cadr(sc->args)); - - if(index>=ivalue(car(sc->args))) { - Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); - } - - s_return(sc,vector_elem(car(sc->args),index)); - } - - case OP_VECSET: { /* vector-set! */ - int index; - - if(is_immutable(car(sc->args))) { - Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args)); - } - - index=ivalue(cadr(sc->args)); - if(index>=ivalue(car(sc->args))) { - Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); - } - - set_vector_elem(car(sc->args),index,caddr(sc->args)); - s_return(sc,car(sc->args)); - } - - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static int list_length(scheme *sc, pointer a) { - int v=0; - pointer x; - for (x = a, v = 0; is_pair(x); x = cdr(x)) { - ++v; - } - if(x==sc->NIL) { - return v; - } - return -1; -} - -static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; - int (*comp_func)(num,num)=0; - - switch (op) { - case OP_NOT: /* not */ - s_retbool(is_false(car(sc->args))); - case OP_BOOLP: /* boolean? */ - s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); - case OP_EOFOBJP: /* boolean? */ - s_retbool(car(sc->args) == sc->EOF_OBJ); - case OP_NULLP: /* null? */ - s_retbool(car(sc->args) == sc->NIL); - case OP_NUMEQ: /* = */ - case OP_LESS: /* < */ - case OP_GRE: /* > */ - case OP_LEQ: /* <= */ - case OP_GEQ: /* >= */ - switch(op) { - case OP_NUMEQ: comp_func=num_eq; break; - case OP_LESS: comp_func=num_lt; break; - case OP_GRE: comp_func=num_gt; break; - case OP_LEQ: comp_func=num_le; break; - case OP_GEQ: comp_func=num_ge; break; - } - x=sc->args; - v=nvalue(car(x)); - x=cdr(x); - - for (; x != sc->NIL; x = cdr(x)) { - if(!comp_func(v,nvalue(car(x)))) { - s_retbool(0); - } - v=nvalue(car(x)); - } - s_retbool(1); - case OP_SYMBOLP: /* symbol? */ - s_retbool(is_symbol(car(sc->args))); - case OP_NUMBERP: /* number? */ - s_retbool(is_number(car(sc->args))); - case OP_STRINGP: /* string? */ - s_retbool(is_string(car(sc->args))); - case OP_INTEGERP: /* integer? */ - s_retbool(is_integer(car(sc->args))); - case OP_REALP: /* real? */ - s_retbool(is_number(car(sc->args))); /* All numbers are real */ - case OP_CHARP: /* char? */ - s_retbool(is_character(car(sc->args))); -#if USE_CHAR_CLASSIFIERS - case OP_CHARAP: /* char-alphabetic? */ - s_retbool(Cisalpha(ivalue(car(sc->args)))); - case OP_CHARNP: /* char-numeric? */ - s_retbool(Cisdigit(ivalue(car(sc->args)))); - case OP_CHARWP: /* char-whitespace? */ - s_retbool(Cisspace(ivalue(car(sc->args)))); - case OP_CHARUP: /* char-upper-case? */ - s_retbool(Cisupper(ivalue(car(sc->args)))); - case OP_CHARLP: /* char-lower-case? */ - s_retbool(Cislower(ivalue(car(sc->args)))); -#endif - case OP_PORTP: /* port? */ - s_retbool(is_port(car(sc->args))); - case OP_INPORTP: /* input-port? */ - s_retbool(is_inport(car(sc->args))); - case OP_OUTPORTP: /* output-port? */ - s_retbool(is_outport(car(sc->args))); - case OP_PROCP: /* procedure? */ - /*-- - * continuation should be procedure by the example - * (call-with-current-continuation procedure?) ==> #t - * in R^3 report sec. 6.9 - */ - s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) - || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); - case OP_PAIRP: /* pair? */ - s_retbool(is_pair(car(sc->args))); - case OP_LISTP: { /* list? */ - pointer slow, fast; - slow = fast = car(sc->args); - while (1) { - if (!is_pair(fast)) s_retbool(fast == sc->NIL); - fast = cdr(fast); - if (!is_pair(fast)) s_retbool(fast == sc->NIL); - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) { - /* the fast pointer has looped back around and caught up - with the slow pointer, hence the structure is circular, - not of finite length, and therefore not a list */ - s_retbool(0); - } - } - } - case OP_ENVP: /* environment? */ - s_retbool(is_environment(car(sc->args))); - case OP_VECTORP: /* vector? */ - s_retbool(is_vector(car(sc->args))); - case OP_EQ: /* eq? */ - s_retbool(car(sc->args) == cadr(sc->args)); - case OP_EQV: /* eqv? */ - s_retbool(eqv(car(sc->args), cadr(sc->args))); - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - - switch (op) { - case OP_FORCE: /* force */ - sc->code = car(sc->args); - if (is_promise(sc->code)) { - /* Should change type to closure here */ - s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_APPLY); - } else { - s_return(sc,sc->code); - } - - case OP_SAVE_FORCED: /* Save forced value replacing promise */ - memcpy(sc->code,sc->value,sizeof(struct cell)); - s_return(sc,sc->value); - - case OP_WRITE: /* write */ - case OP_DISPLAY: /* display */ - case OP_WRITE_CHAR: /* write-char */ - if(is_pair(cdr(sc->args))) { - if(cadr(sc->args)!=sc->outport) { - x=cons(sc,sc->outport,sc->NIL); - s_save(sc,OP_SET_OUTPORT, x, sc->NIL); - sc->outport=cadr(sc->args); - } - } - sc->args = car(sc->args); - if(op==OP_WRITE) { - sc->print_flag = 1; - } else { - sc->print_flag = 0; - } - s_goto(sc,OP_P0LIST); - - case OP_NEWLINE: /* newline */ - if(is_pair(sc->args)) { - if(car(sc->args)!=sc->outport) { - x=cons(sc,sc->outport,sc->NIL); - s_save(sc,OP_SET_OUTPORT, x, sc->NIL); - sc->outport=car(sc->args); - } - } - putstr(sc, "\n"); - s_return(sc,sc->T); - - case OP_ERR0: /* error */ - sc->retcode=-1; - if (!is_string(car(sc->args))) { - sc->args=cons(sc,mk_string(sc," -- "),sc->args); - setimmutable(car(sc->args)); - } - putstr(sc, ErrorHeader); - putstr(sc, strvalue(car(sc->args))); - sc->args = cdr(sc->args); - s_goto(sc,OP_ERR1); - - case OP_ERR1: /* error */ - putstr(sc, " "); - if (sc->args != sc->NIL) { - s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); - sc->args = car(sc->args); - sc->print_flag = 1; - s_goto(sc,OP_P0LIST); - } else { - putstr(sc, "\n"); - if(sc->interactive_repl) { - s_goto(sc,OP_T0LVL); - } else { - return sc->NIL; - } - } - - case OP_REVERSE: /* reverse */ - s_return(sc,reverse(sc, car(sc->args))); - - case OP_LIST_STAR: /* list* */ - s_return(sc,list_star(sc,sc->args)); - - case OP_APPEND: /* append */ - if(sc->args==sc->NIL) { - s_return(sc,sc->NIL); - } - x=car(sc->args); - if(cdr(sc->args)==sc->NIL) { - s_return(sc,sc->args); - } - for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) { - x=append(sc,x,car(y)); - } - s_return(sc,x); - -#if USE_PLIST - case OP_PUT: /* put */ - if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { - Error_0(sc,"illegal use of put"); - } - for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { - if (caar(x) == y) { - break; - } - } - if (x != sc->NIL) - cdar(x) = caddr(sc->args); - else - symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), - symprop(car(sc->args))); - s_return(sc,sc->T); - - case OP_GET: /* get */ - if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { - Error_0(sc,"illegal use of get"); - } - for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { - if (caar(x) == y) { - break; - } - } - if (x != sc->NIL) { - s_return(sc,cdar(x)); - } else { - s_return(sc,sc->NIL); - } -#endif /* USE_PLIST */ - case OP_QUIT: /* quit */ - if(is_pair(sc->args)) { - sc->retcode=ivalue(car(sc->args)); - } - return (sc->NIL); - - case OP_GC: /* gc */ - gc(sc, sc->NIL, sc->NIL); - s_return(sc,sc->T); - - case OP_GCVERB: /* gc-verbose */ - { int was = sc->gc_verbose; - - sc->gc_verbose = (car(sc->args) != sc->F); - s_retbool(was); - } - - case OP_NEWSEGMENT: /* new-segment */ - if (!is_pair(sc->args) || !is_number(car(sc->args))) { - Error_0(sc,"new-segment: argument must be a number"); - } - alloc_cellseg(sc, (int) ivalue(car(sc->args))); - s_return(sc,sc->T); - - case OP_OBLIST: /* oblist */ - s_return(sc, oblist_all_symbols(sc)); - - case OP_CURR_INPORT: /* current-input-port */ - s_return(sc,sc->inport); - - case OP_CURR_OUTPORT: /* current-output-port */ - s_return(sc,sc->outport); - - case OP_OPEN_INFILE: /* open-input-file */ - case OP_OPEN_OUTFILE: /* open-output-file */ - case OP_OPEN_INOUTFILE: /* open-input-output-file */ { - int prop=0; - pointer p; - switch(op) { - case OP_OPEN_INFILE: prop=port_input; break; - case OP_OPEN_OUTFILE: prop=port_output; break; - case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; - } - p=port_from_filename(sc,strvalue(car(sc->args)),prop); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - s_return(sc,p); - } - -#if USE_STRING_PORTS - case OP_OPEN_INSTRING: /* open-input-string */ - case OP_OPEN_OUTSTRING: /* open-output-string */ - case OP_OPEN_INOUTSTRING: /* open-input-output-string */ { - int prop=0; - pointer p; - switch(op) { - case OP_OPEN_INSTRING: prop=port_input; break; - case OP_OPEN_OUTSTRING: prop=port_output; break; - case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; - } - p=port_from_string(sc, strvalue(car(sc->args)), - strvalue(car(sc->args))+strlength(car(sc->args)), prop); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - s_return(sc,p); - } -#endif - - case OP_CLOSE_INPORT: /* close-input-port */ - port_close(sc,car(sc->args),port_input); - s_return(sc,sc->T); - - case OP_CLOSE_OUTPORT: /* close-output-port */ - port_close(sc,car(sc->args),port_output); - s_return(sc,sc->T); - - case OP_INT_ENV: /* interaction-environment */ - s_return(sc,sc->global_env); - - case OP_CURR_ENV: /* current-environment */ - s_return(sc,sc->envir); - - } - return sc->T; -} - -static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { - pointer x; - - if(sc->nesting!=0) { - int n=sc->nesting; - sc->nesting=0; - sc->retcode=-1; - Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); - } - - switch (op) { - /* ========== reading part ========== */ - case OP_READ: - if(!is_pair(sc->args)) { - s_goto(sc,OP_READ_INTERNAL); - } - if(!is_inport(car(sc->args))) { - Error_1(sc,"read: not an input port:",car(sc->args)); - } - if(car(sc->args)==sc->inport) { - s_goto(sc,OP_READ_INTERNAL); - } - x=sc->inport; - sc->inport=car(sc->args); - x=cons(sc,x,sc->NIL); - s_save(sc,OP_SET_INPORT, x, sc->NIL); - s_goto(sc,OP_READ_INTERNAL); - - case OP_READ_CHAR: /* read-char */ - case OP_PEEK_CHAR: /* peek-char */ { - int c; - if(is_pair(sc->args)) { - if(car(sc->args)!=sc->inport) { - x=sc->inport; - x=cons(sc,x,sc->NIL); - s_save(sc,OP_SET_INPORT, x, sc->NIL); - sc->inport=car(sc->args); - } - } - c=inchar(sc); - if(c==EOF) { - s_return(sc,sc->EOF_OBJ); - } - if(sc->op==OP_PEEK_CHAR) { - backchar(sc,c); - } - s_return(sc,mk_character(sc,c)); - } - - case OP_CHAR_READY: /* char-ready? */ { - pointer p=sc->inport; - int res; - if(is_pair(sc->args)) { - p=car(sc->args); - } - res=p->_object._port->kind&port_string; - s_retbool(res); - } - - case OP_SET_INPORT: /* set-input-port */ - sc->inport=car(sc->args); - s_return(sc,sc->value); - - case OP_SET_OUTPORT: /* set-output-port */ - sc->outport=car(sc->args); - s_return(sc,sc->value); - - case OP_RDSEXPR: - switch (sc->tok) { - case TOK_EOF: - if(sc->inport==sc->loadport) { - sc->args=sc->NIL; - s_goto(sc,OP_QUIT); - } else { - s_return(sc,sc->EOF_OBJ); - } -/* - * Commented out because we now skip comments in the scanner - * - case TOK_COMMENT: { - int c; - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - } -*/ - case TOK_VEC: - s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); - /* fall through */ - case TOK_LPAREN: - sc->tok = token(sc); - if (sc->tok == TOK_RPAREN) { - s_return(sc,sc->NIL); - } else if (sc->tok == TOK_DOT) { - Error_0(sc,"syntax error: illegal dot expression"); - } else { - sc->nesting_stack[sc->file_i]++; - s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); - s_goto(sc,OP_RDSEXPR); - } - case TOK_QUOTE: - s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - case TOK_BQUOTE: - sc->tok = token(sc); - if(sc->tok==TOK_VEC) { - s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); - sc->tok=TOK_LPAREN; - s_goto(sc,OP_RDSEXPR); - } else { - s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); - } - s_goto(sc,OP_RDSEXPR); - case TOK_COMMA: - s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - case TOK_ATMARK: - s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - case TOK_ATOM: - s_return(sc,mk_atom(sc, readstr_upto(sc, "();\t\n\r "))); - case TOK_DQUOTE: - x=readstrexp(sc); - if(x==sc->F) { - Error_0(sc,"Error reading string"); - } - setimmutable(x); - s_return(sc,x); - case TOK_SHARP: { - pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); - if(f==sc->NIL) { - Error_0(sc,"undefined sharp expression"); - } else { - sc->code=cons(sc,slot_value_in_env(f),sc->NIL); - s_goto(sc,OP_EVAL); - } - } - case TOK_SHARP_CONST: - if ((x = mk_sharp_const(sc, readstr_upto(sc, "();\t\n\r "))) == sc->NIL) { - Error_0(sc,"undefined sharp expression"); - } else { - s_return(sc,x); - } - default: - Error_0(sc,"syntax error: illegal token"); - } - break; - - case OP_RDLIST: { - sc->args = cons(sc, sc->value, sc->args); - sc->tok = token(sc); -/* We now skip comments in the scanner - - while (sc->tok == TOK_COMMENT) { - int c; - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - sc->tok = token(sc); - } -*/ - if (sc->tok == TOK_RPAREN) { - int c = inchar(sc); - if (c != '\n') backchar(sc,c); - sc->nesting_stack[sc->file_i]--; - s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); - } else if (sc->tok == TOK_DOT) { - s_save(sc,OP_RDDOT, sc->args, sc->NIL); - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - } else { - s_save(sc,OP_RDLIST, sc->args, sc->NIL);; - s_goto(sc,OP_RDSEXPR); - } - } - - case OP_RDDOT: - if (token(sc) != TOK_RPAREN) { - Error_0(sc,"syntax error: illegal dot expression"); - } else { - sc->nesting_stack[sc->file_i]--; - s_return(sc,reverse_in_place(sc, sc->value, sc->args)); - } - - case OP_RDQUOTE: - s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); - - case OP_RDQQUOTE: - s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); - - case OP_RDQQUOTEVEC: - s_return(sc,cons(sc, mk_symbol(sc,"apply"), - cons(sc, mk_symbol(sc,"vector"), - cons(sc,cons(sc, sc->QQUOTE, - cons(sc,sc->value,sc->NIL)), - sc->NIL)))); - - case OP_RDUNQUOTE: - s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); - - case OP_RDUQTSP: - s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); - - case OP_RDVEC: - /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_goto(sc,OP_EVAL); Cannot be quoted*/ - /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_return(sc,x); Cannot be part of pairs*/ - /*sc->code=mk_proc(sc,OP_VECTOR); - sc->args=sc->value; - s_goto(sc,OP_APPLY);*/ - sc->args=sc->value; - s_goto(sc,OP_VECTOR); - - /* ========== printing part ========== */ - case OP_P0LIST: - if(is_vector(sc->args)) { - putstr(sc,"#("); - sc->args=cons(sc,sc->args,mk_integer(sc,0)); - s_goto(sc,OP_PVECFROM); - } else if(is_environment(sc->args)) { - putstr(sc,"#"); - s_return(sc,sc->T); - } else if (!is_pair(sc->args)) { - printatom(sc, sc->args, sc->print_flag); - s_return(sc,sc->T); - } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, "'"); - sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); - } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, "`"); - sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); - } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, ","); - sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); - } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { - putstr(sc, ",@"); - sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); - } else { - putstr(sc, "("); - s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); - sc->args = car(sc->args); - s_goto(sc,OP_P0LIST); - } - - case OP_P1LIST: - if (is_pair(sc->args)) { - s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); - putstr(sc, " "); - sc->args = car(sc->args); - s_goto(sc,OP_P0LIST); - } else if(is_vector(sc->args)) { - s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); - putstr(sc, " . "); - s_goto(sc,OP_P0LIST); - } else { - if (sc->args != sc->NIL) { - putstr(sc, " . "); - printatom(sc, sc->args, sc->print_flag); - } - putstr(sc, ")"); - s_return(sc,sc->T); - } - case OP_PVECFROM: { - int i=ivalue_unchecked(cdr(sc->args)); - pointer vec=car(sc->args); - int len=ivalue_unchecked(vec); - if(i==len) { - putstr(sc,")"); - s_return(sc,sc->T); - } else { - pointer elem=vector_elem(vec,i); - ivalue_unchecked(cdr(sc->args))=i+1; - s_save(sc,OP_PVECFROM, sc->args, sc->NIL); - sc->args=elem; - putstr(sc," "); - s_goto(sc,OP_P0LIST); - } - } - - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - - } - return sc->T; -} - -static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - long v; - - switch (op) { - case OP_LIST_LENGTH: /* length */ /* a.k */ - v=list_length(sc,car(sc->args)); - if(v<0) { - Error_1(sc,"length: not a list:",car(sc->args)); - } - s_return(sc,mk_integer(sc, v)); - - case OP_ASSQ: /* assq */ /* a.k */ - x = car(sc->args); - for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { - if (!is_pair(car(y))) { - Error_0(sc,"unable to handle non pair element"); - } - if (x == caar(y)) - break; - } - if (is_pair(y)) { - s_return(sc,car(y)); - } else { - s_return(sc,sc->F); - } - - - case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ - sc->args = car(sc->args); - if (sc->args == sc->NIL) { - s_return(sc,sc->F); - } else if (is_closure(sc->args)) { - s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); - } else if (is_macro(sc->args)) { - s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); - } else { - s_return(sc,sc->F); - } - case OP_CLOSUREP: /* closure? */ - /* - * Note, macro object is also a closure. - * Therefore, (closure? <#MACRO>) ==> #t - */ - s_retbool(is_closure(car(sc->args))); - case OP_MACROP: /* macro? */ - s_retbool(is_macro(car(sc->args))); - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; /* NOTREACHED */ -} - -typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); - -typedef int (*test_predicate)(pointer); -static int is_any(pointer p) { return 1;} -static int is_num_integer(pointer p) { - return is_number(p) && ((p)->_object._number.is_fixnum); -} -static int is_nonneg(pointer p) { - return is_num_integer(p) && ivalue(p)>=0; -} - -/* Correspond carefully with following defines! */ -static struct { - test_predicate fct; - const char *kind; -} tests[]={ - {0,0}, /* unused */ - {is_any, 0}, - {is_string, "string"}, - {is_symbol, "symbol"}, - {is_port, "port"}, - {0,"input port"}, - {0,"output_port"}, - {is_environment, "environment"}, - {is_pair, "pair"}, - {0, "pair or '()"}, - {is_character, "character"}, - {is_vector, "vector"}, - {is_number, "number"}, - {is_num_integer, "integer"}, - {is_nonneg, "non-negative integer"} -}; - -#define TST_NONE 0 -#define TST_ANY "\001" -#define TST_STRING "\002" -#define TST_SYMBOL "\003" -#define TST_PORT "\004" -#define TST_INPORT "\005" -#define TST_OUTPORT "\006" -#define TST_ENVIRONMENT "\007" -#define TST_PAIR "\010" -#define TST_LIST "\011" -#define TST_CHAR "\012" -#define TST_VECTOR "\013" -#define TST_NUMBER "\014" -#define TST_INTEGER "\015" -#define TST_NATURAL "\016" - -typedef struct { - dispatch_func func; - char *name; - int min_arity; - int max_arity; - char *arg_tests_encoding; -} op_code_info; - -#define INF_ARG 0xffff - -static op_code_info dispatch_table[]= { -#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, -#include "opdefines.h" - { 0 } -}; - -static const char *procname(pointer x) { - int n=procnum(x); - const char *name=dispatch_table[n].name; - if(name==0) { - name="ILLEGAL!"; - } - return name; -} - -/* kernel of this interpreter */ -static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { - int count=0; - int old_op; - - char msg[512]; - sc->op = op; - for (;;) { - op_code_info *pcd=dispatch_table+sc->op; - if (pcd->name!=0) { /* if built-in function, check arguments */ - //char msg[512]; - int ok=1; - int n=list_length(sc,sc->args); - - /* Check number of arguments */ - if(nmin_arity) { - ok=0; - sprintf(msg,"%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity==pcd->max_arity?"":" at least", - pcd->min_arity); - } - if(ok && n>pcd->max_arity) { - ok=0; - sprintf(msg,"%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity==pcd->max_arity?"":" at most", - pcd->max_arity); - } - if(ok) { - if(pcd->arg_tests_encoding!=0) { - int i=0; - int j; - const char *t=pcd->arg_tests_encoding; - pointer arglist=sc->args; - do { - pointer arg=car(arglist); - j=(int)t[0]; - if(j==TST_INPORT[0]) { - if(!is_inport(arg)) break; - } else if(j==TST_OUTPORT[0]) { - if(!is_outport(arg)) break; - } else if(j==TST_LIST[0]) { - if(arg!=sc->NIL && !is_pair(arg)) break; - } else { - if(!tests[j].fct(arg)) break; - } - - if(t[1]!=0) {/* last test is replicated as necessary */ - t++; - } - arglist=cdr(arglist); - i++; - } while(iname, - i+1, - tests[j].kind); - } - } - } - if(!ok) { - if(_Error_1(sc,msg,0)==sc->NIL) { - return; - } - pcd=dispatch_table+sc->op; - } - } - old_op=sc->op; - if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { - return; - } - if(sc->no_memory) { - fprintf(stderr,"No memory!\n"); - return; - } - count++; - } -} - -/* ========== Initialization of internal keywords ========== */ - -static void assign_syntax(scheme *sc, char *name) { - pointer x; - - x = oblist_add_by_name(sc, name); - typeflag(x) |= T_SYNTAX; -} - -static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { - pointer x, y; - - x = mk_symbol(sc, name); - y = mk_proc(sc,op); - new_slot_in_env(sc, x, y); -} - -static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { - pointer y; - - y = get_cell(sc, sc->NIL, sc->NIL); - typeflag(y) = (T_PROC | T_ATOM); - ivalue_unchecked(y) = (long) op; - set_integer(y); - return y; -} - -/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ -static int syntaxnum(pointer p) { - const char *s=strvalue(car(p)); - switch(strlength(car(p))) { - case 2: - if(s[0]=='i') return OP_IF0; /* if */ - if(s[1]=='n') return OP_LAMBDA2; /* fn */ - else return OP_OR0; /* or */ - case 3: - if(s[0]=='a') return OP_AND0; /* and */ - else return OP_LET0; /* let */ - case 4: - switch(s[3]) { - case 'e': return OP_CASE0; /* case */ - case 'd': return OP_COND0; /* cond */ - case '*': return OP_LET0AST; /* let* */ - default: return OP_SET0; /* set! */ - } - case 5: - switch(s[2]) { - case 'g': return OP_BEGIN; /* begin */ - case 'l': return OP_DELAY; /* delay */ - case 'c': return OP_MACRO0; /* macro */ - default: return OP_QUOTE; /* quote */ - } - case 6: - switch(s[2]) { - case 'm': return OP_LAMBDA; /* lambda */ - case 'f': return OP_DEF0; /* define */ - default: return OP_LET0REC; /* letrec */ - } - default: - return OP_C0STREAM; /* cons-stream */ - } -} - -/* initialization of TinyScheme */ -#if USE_INTERFACE -INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { - return cons(sc,a,b); -} -INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { - return immutable_cons(sc,a,b); -} - -static struct scheme_interface vtbl ={ - scheme_define, - s_cons, - s_immutable_cons, - reserve_cells, - mk_integer, - mk_real, - mk_symbol, - gensym, - mk_string, - mk_counted_string, - mk_character, - mk_vector, - mk_foreign_func, - putstr, - putcharacter, - - is_string, - string_value, - is_number, - nvalue, - ivalue, - rvalue, - is_integer, - is_real, - is_character, - charvalue, - is_vector, - ivalue, - fill_vector, - vector_elem, - set_vector_elem, - is_port, - is_pair, - pair_car, - pair_cdr, - set_car, - set_cdr, - - is_symbol, - symname, - - is_syntax, - is_proc, - is_foreign, - syntaxname, - is_closure, - is_macro, - closure_code, - closure_env, - - is_continuation, - is_promise, - is_environment, - is_immutable, - setimmutable, - - scheme_load_file, - scheme_load_string, - - scheme_error -}; -#endif - -scheme *scheme_init_new() { - scheme *sc=(scheme*)malloc(sizeof(scheme)); - if(!scheme_init(sc)) { - free(sc); - return 0; - } else { - return sc; - } -} - -scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { - scheme *sc=(scheme*)malloc(sizeof(scheme)); - if(!scheme_init_custom_alloc(sc,malloc,free)) { - free(sc); - return 0; - } else { - return sc; - } -} - - -int scheme_init(scheme *sc) { - return scheme_init_custom_alloc(sc,malloc,free); -} - -int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { - int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); - pointer x; - - num_zero.is_fixnum=1; - num_zero.value.ivalue=0; - num_one.is_fixnum=1; - num_one.value.ivalue=1; - -#if USE_INTERFACE - sc->vptr=&vtbl; -#endif - sc->gensym_cnt=0; - sc->malloc=malloc; - sc->free=free; - sc->last_cell_seg = -1; - sc->sink = &sc->_sink; - sc->NIL = &sc->_NIL; - sc->T = &sc->_HASHT; - sc->F = &sc->_HASHF; - sc->EOF_OBJ=&sc->_EOF_OBJ; - sc->free_cell = &sc->_NIL; - sc->fcells = 0; - sc->no_memory=0; - sc->inport=sc->NIL; - sc->outport=sc->NIL; - sc->save_inport=sc->NIL; - sc->loadport=sc->NIL; - sc->nesting=0; - sc->interactive_repl=0; - - if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { - sc->no_memory=1; - return 0; - } - sc->gc_verbose = 0; - dump_stack_initialize(sc); - sc->code = sc->NIL; - sc->tracing=0; - - /* init sc->NIL */ - typeflag(sc->NIL) = (T_ATOM | MARK); - car(sc->NIL) = cdr(sc->NIL) = sc->NIL; - /* init T */ - typeflag(sc->T) = (T_ATOM | MARK); - car(sc->T) = cdr(sc->T) = sc->T; - /* init F */ - typeflag(sc->F) = (T_ATOM | MARK); - car(sc->F) = cdr(sc->F) = sc->F; - sc->oblist = oblist_initial_value(sc); - /* init global_env */ - new_frame_in_env(sc, sc->NIL); - sc->global_env = sc->envir; - /* init else */ - x = mk_symbol(sc,"else"); - new_slot_in_env(sc, x, sc->T); - - assign_syntax(sc, "fn"); - assign_syntax(sc, "lambda"); - assign_syntax(sc, "quote"); - assign_syntax(sc, "define"); - assign_syntax(sc, "if"); - assign_syntax(sc, "begin"); - assign_syntax(sc, "set!"); - assign_syntax(sc, "let"); - assign_syntax(sc, "let*"); - assign_syntax(sc, "letrec"); - assign_syntax(sc, "cond"); - assign_syntax(sc, "delay"); - assign_syntax(sc, "and"); - assign_syntax(sc, "or"); - assign_syntax(sc, "cons-stream"); - assign_syntax(sc, "macro"); - assign_syntax(sc, "case"); - - for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); - sc->LAMBDA2 = mk_symbol(sc, "fn"); - sc->QUOTE = mk_symbol(sc, "quote"); - sc->QQUOTE = mk_symbol(sc, "quasiquote"); - sc->UNQUOTE = mk_symbol(sc, "unquote"); - sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); - sc->FEED_TO = mk_symbol(sc, "=>"); - sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); - sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); - sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); - - return !sc->no_memory; -} - -void scheme_set_input_port_file(scheme *sc, FILE *fin) { - sc->inport=port_from_file(sc,fin,port_input); -} - -void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { - sc->inport=port_from_string(sc,start,past_the_end,port_input); -} - -void scheme_set_output_port_file(scheme *sc, FILE *fout) { - sc->outport=port_from_file(sc,fout,port_output); -} - -void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { - sc->outport=port_from_string(sc,start,past_the_end,port_output); -} - -void scheme_set_external_data(scheme *sc, void *p) { - sc->ext_data=p; -} - -void scheme_deinit(scheme *sc) { - int i; - - sc->oblist=sc->NIL; - sc->global_env=sc->NIL; - dump_stack_free(sc); - sc->envir=sc->NIL; - sc->code=sc->NIL; - sc->args=sc->NIL; - sc->value=sc->NIL; - if(is_port(sc->inport)) { - typeflag(sc->inport) = T_ATOM; - } - sc->inport=sc->NIL; - sc->outport=sc->NIL; - if(is_port(sc->save_inport)) { - typeflag(sc->save_inport) = T_ATOM; - } - sc->save_inport=sc->NIL; - if(is_port(sc->loadport)) { - typeflag(sc->loadport) = T_ATOM; - } - sc->loadport=sc->NIL; - sc->gc_verbose=0; - gc(sc,sc->NIL,sc->NIL); - - for(i=0; i<=sc->last_cell_seg; i++) { - sc->free(sc->alloc_seg[i]); - } -} - -void scheme_load_file(scheme *sc, FILE *fin) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->file_i=0; - sc->load_stack[0].kind=port_input|port_file; - sc->load_stack[0].rep.stdio.file=fin; - sc->loadport=mk_port(sc,sc->load_stack); - sc->retcode=0; - if(fin==stdin) { - sc->interactive_repl=1; - } - sc->inport=sc->loadport; - Eval_Cycle(sc, OP_T0LVL); - typeflag(sc->loadport)=T_ATOM; - if(sc->retcode==0) { - sc->retcode=sc->nesting!=0; - } -} - -void scheme_load_string(scheme *sc, const char *cmd) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->file_i=0; - sc->load_stack[0].kind=port_input|port_string; - sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ - sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); - sc->load_stack[0].rep.string.curr=(char*)cmd; - sc->loadport=mk_port(sc,sc->load_stack); - sc->retcode=0; - sc->interactive_repl=0; - sc->inport=sc->loadport; - Eval_Cycle(sc, OP_T0LVL); - typeflag(sc->loadport)=T_ATOM; - if(sc->retcode==0) { - sc->retcode=sc->nesting!=0; - } -} - -void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { - pointer x; - - x=find_slot_in_env(sc,envir,symbol,0); - if (x != sc->NIL) { - set_slot_in_env(sc, x, value); - } else { - new_slot_spec_in_env(sc, envir, symbol, value); - } -} - -void scheme_error(scheme *sc, const char *str) { - putstr(sc, ErrorHeader); - putstr(sc, str); - putstr(sc, "\n"); -} - -#if !STANDALONE -void scheme_apply0(scheme *sc, const char *procname) { - pointer carx=mk_symbol(sc,procname); - pointer cdrx=sc->NIL; - - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->code = cons(sc,carx,cdrx); - sc->interactive_repl=0; - sc->retcode=0; - Eval_Cycle(sc,OP_EVAL); -} - -void scheme_call(scheme *sc, pointer func, pointer args) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->args = args; - sc->code = func; - sc->interactive_repl =0; - sc->retcode = 0; - Eval_Cycle(sc, OP_APPLY); -} -#endif diff --git a/tools/capone/src/scheme.h b/tools/capone/src/scheme.h deleted file mode 100644 index 5bab588..0000000 --- a/tools/capone/src/scheme.h +++ /dev/null @@ -1,221 +0,0 @@ -/* SCHEME.H */ - -#ifndef _SCHEME_H -#define _SCHEME_H - -#include - -/* - * Default values for #define'd symbols - */ - -/* If used as standalone interpreter */ -#ifndef STANDALONE -# define STANDALONE 1 -#endif - -#ifndef _MSC_VER -# define USE_STRCASECMP 1 -# ifndef USE_STRLWR -# define USE_STRLWR 1 -# endif -# define SCHEME_EXPORT -#else -# define USE_STRCASECMP 0 -# define USE_STRLWR 0 -# ifdef _SCHEME_SOURCE -# define SCHEME_EXPORT __declspec(dllexport) -# else -# define SCHEME_EXPORT __declspec(dllimport) -# endif -#endif - -#if USE_NO_FEATURES -# define USE_MATH 0 -# define USE_CHAR_CLASSIFIERS 0 -# define USE_ASCII_NAMES 0 -# define USE_STRING_PORTS 0 -# define USE_ERROR_HOOK 0 -# define USE_TRACING 0 -# define USE_COLON_HOOK 0 -# define USE_DL 0 -# define USE_PLIST 0 -#endif - -/* - * Leave it defined if you want continuations, and also for the Sharp Zaurus. - * Undefine it if you only care about faster speed and not strict Scheme compatibility. - */ -#define USE_SCHEME_STACK - -#if USE_DL -# define USE_INTERFACE 1 -#endif - - -#ifndef USE_MATH /* If math support is needed */ -# define USE_MATH 1 -#endif - -#ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */ -# define USE_CHAR_CLASSIFIERS 1 -#endif - -#ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */ -# define USE_ASCII_NAMES 1 -#endif - -#ifndef USE_STRING_PORTS /* Enable string ports */ -# define USE_STRING_PORTS 1 -#endif - -#ifndef USE_TRACING -# define USE_TRACING 1 -#endif - -#ifndef USE_PLIST -# define USE_PLIST 0 -#endif - -/* To force system errors through user-defined error handling (see *error-hook*) */ -#ifndef USE_ERROR_HOOK -# define USE_ERROR_HOOK 1 -#endif - -#ifndef USE_COLON_HOOK /* Enable qualified qualifier */ -# define USE_COLON_HOOK 1 -#endif - -#ifndef USE_STRCASECMP /* stricmp for Unix */ -# define USE_STRCASECMP 0 -#endif - -#ifndef USE_STRLWR -# define USE_STRLWR 1 -#endif - -#ifndef STDIO_ADDS_CR /* Define if DOS/Windows */ -# define STDIO_ADDS_CR 0 -#endif - -#ifndef INLINE -# define INLINE -#endif - -#ifndef USE_INTERFACE -# define USE_INTERFACE 0 -#endif - -typedef struct scheme scheme; -typedef struct cell *pointer; - -typedef void * (*func_alloc)(size_t); -typedef void (*func_dealloc)(void *); - -/* num, for generic arithmetic */ -typedef struct num { - char is_fixnum; - union { - long ivalue; - double rvalue; - } value; -} num; - -SCHEME_EXPORT scheme *scheme_init_new(); -SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free); -SCHEME_EXPORT int scheme_init(scheme *sc); -SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc); -SCHEME_EXPORT void scheme_deinit(scheme *sc); -void scheme_set_input_port_file(scheme *sc, FILE *fin); -void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end); -SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin); -void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); -SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); -SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); -void scheme_apply0(scheme *sc, const char *procname); -SCHEME_EXPORT pointer scheme_apply1(scheme *sc, const char *procname, pointer); -void scheme_set_external_data(scheme *sc, void *p); -SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); -SCHEME_EXPORT void scheme_error(scheme *sc, const char *str); - -typedef pointer (*foreign_func)(scheme *, pointer); - -pointer _cons(scheme *sc, pointer a, pointer b, int immutable); -pointer mk_integer(scheme *sc, long num); -pointer mk_real(scheme *sc, double num); -pointer mk_symbol(scheme *sc, const char *name); -pointer gensym(scheme *sc); -pointer mk_string(scheme *sc, const char *str); -pointer mk_counted_string(scheme *sc, const char *str, int len); -pointer mk_character(scheme *sc, int c); -pointer mk_foreign_func(scheme *sc, foreign_func f); -void putstr(scheme *sc, const char *s); - - -#if USE_INTERFACE -struct scheme_interface { - void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value); - pointer (*cons)(scheme *sc, pointer a, pointer b); - pointer (*immutable_cons)(scheme *sc, pointer a, pointer b); - pointer (*reserve_cells)(scheme *sc, int n); - pointer (*mk_integer)(scheme *sc, long num); - pointer (*mk_real)(scheme *sc, double num); - pointer (*mk_symbol)(scheme *sc, const char *name); - pointer (*gensym)(scheme *sc); - pointer (*mk_string)(scheme *sc, const char *str); - pointer (*mk_counted_string)(scheme *sc, const char *str, int len); - pointer (*mk_character)(scheme *sc, int c); - pointer (*mk_vector)(scheme *sc, int len); - pointer (*mk_foreign_func)(scheme *sc, foreign_func f); - void (*putstr)(scheme *sc, const char *s); - void (*putcharacter)(scheme *sc, int c); - - int (*is_string)(pointer p); - char *(*string_value)(pointer p); - int (*is_number)(pointer p); - num (*nvalue)(pointer p); - long (*ivalue)(pointer p); - double (*rvalue)(pointer p); - int (*is_integer)(pointer p); - int (*is_real)(pointer p); - int (*is_character)(pointer p); - long (*charvalue)(pointer p); - int (*is_vector)(pointer p); - long (*vector_length)(pointer vec); - void (*fill_vector)(pointer vec, pointer elem); - pointer (*vector_elem)(pointer vec, int ielem); - pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel); - int (*is_port)(pointer p); - - int (*is_pair)(pointer p); - pointer (*pair_car)(pointer p); - pointer (*pair_cdr)(pointer p); - pointer (*set_car)(pointer p, pointer q); - pointer (*set_cdr)(pointer p, pointer q); - - int (*is_symbol)(pointer p); - char *(*symname)(pointer p); - - int (*is_syntax)(pointer p); - int (*is_proc)(pointer p); - int (*is_foreign)(pointer p); - char *(*syntaxname)(pointer p); - int (*is_closure)(pointer p); - int (*is_macro)(pointer p); - pointer (*closure_code)(pointer p); - pointer (*closure_env)(pointer p); - - int (*is_continuation)(pointer p); - int (*is_promise)(pointer p); - int (*is_environment)(pointer p); - int (*is_immutable)(pointer p); - void (*setimmutable)(pointer p); - void (*load_file)(scheme *sc, FILE *fin); - void (*load_string)(scheme *sc, const char *input); - - void (*error)(scheme *sc, const char *str); -}; -#endif - -#endif - diff --git a/tools/capone/src/sys.cpp b/tools/capone/src/sys.cpp deleted file mode 100644 index 4bdc19f..0000000 --- a/tools/capone/src/sys.cpp +++ /dev/null @@ -1,109 +0,0 @@ -#include -#include -#include -#include - -#include - -extern "C" { -#define USE_INTERFACE 1 - -#include "scheme-private.h" -#include "scheme.h" -} - -#include "sys.h" - -extern char** environ; -extern pointer reverse_in_place(scheme *sc, pointer term, pointer list); - -/* - * (getenv ) => - * returns environment value for ; if is not - * given, returns a list of all environment key/value pairs - */ -static pointer s_getenv(scheme* sc, pointer arg) { - if(arg == sc->NIL) { - char** env = environ; - pointer lst = sc->NIL; - - while(*env) { - lst = cons(sc, mk_string(sc, *env), lst); - env++; - } - - return reverse_in_place(sc, sc->NIL, lst); - } - - pointer a = sc->vptr->pair_car(arg); - if(a != sc->NIL && sc->vptr->is_string(a)) { - const char* val; - if((val = getenv(sc->vptr->string_value(a))) != NULL) - return mk_string(sc, val); - } - - return sc->F; -} - -static pointer s_setenv(scheme* sc, pointer args) { - if(args == sc->NIL) - return sc->F; - - const char* key, *val; - pointer a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - key = sc->vptr->string_value(a); - - args = sc->vptr->pair_cdr(args); - a = sc->vptr->pair_car(args); - if(a == sc->NIL || !sc->vptr->is_string(a)) - return sc->F; - val = sc->vptr->string_value(a); - - if(edelib_setenv(key, val, 1) == 0) - return sc->T; - return sc->F; -} - -static pointer s_clock(scheme* sc, pointer args) { - return mk_real(sc, (double)clock()); -} - -/* originaly 'random-next' sucked badly so this is, hopefully, a better replacement */ -static int seed_inited = 0; - -static pointer s_random_next(scheme* sc, pointer args) { - if(!seed_inited) { - srand(time(0)); - seed_inited = 1; - } - - return mk_integer(sc, rand()); -} - -void register_sys_functions(scheme* sc) { - sc->vptr->scheme_define( - sc, - sc->global_env, - sc->vptr->mk_symbol(sc, "getenv"), - sc->vptr->mk_foreign_func(sc, s_getenv)); - - sc->vptr->scheme_define( - sc, - sc->global_env, - sc->vptr->mk_symbol(sc, "setenv"), - sc->vptr->mk_foreign_func(sc, s_setenv)); - - sc->vptr->scheme_define( - sc, - sc->global_env, - sc->vptr->mk_symbol(sc, "clock"), - sc->vptr->mk_foreign_func(sc, s_clock)); - - sc->vptr->scheme_define( - sc, - sc->global_env, - sc->vptr->mk_symbol(sc, "random-next"), - sc->vptr->mk_foreign_func(sc, s_random_next)); -} diff --git a/tools/capone/src/sys.h b/tools/capone/src/sys.h deleted file mode 100644 index 10c1f47..0000000 --- a/tools/capone/src/sys.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef __SYS_H__ -#define __SYS_H__ - -void register_sys_functions(scheme* sc); - -#endif diff --git a/tools/capone/src/tok.ss b/tools/capone/src/tok.ss deleted file mode 100644 index 54cfa32..0000000 --- a/tools/capone/src/tok.ss +++ /dev/null @@ -1,19 +0,0 @@ - -(load "lib/common.ss") - -(define *chars* 0) -(define *lines* 0) - -(define fd (open-input-file "asciidoc.html")) -(set-input-port fd) ;; a bug in tinyscheme ? - -(let loop [(a (read-char fd))] - (if (eof-object? a) - #f - (begin - (set! *chars* (+ 1 *chars*)) - (if (char=? a #\newline) (set! *lines* (+ 1 *lines*))) - (print *lines* "\r") - (loop (read-char fd))))) - -(print "\nWe have " *chars* " characters and " *lines* " lines\n") diff --git a/tools/capone/src/xxx.ss b/tools/capone/src/xxx.ss deleted file mode 100644 index d17b09a..0000000 --- a/tools/capone/src/xxx.ss +++ /dev/null @@ -1,50 +0,0 @@ - -(load "../lib/common.ss") - -;(define l (iota 1000)) - -(define i 0) - -;(for i in l -; (print "The number is: " i "\n") -;) - -;(while (< i 1000) -; (print "The number is: " i "\n") -; (set! i (+ i 1)) -;) - -;(print "Ret from dbus-send is: " -; (dbus-send "SomeSignal" "org.equinoxproject.Demo" "/org/equinoxproject/Demo" "session" "foo") -; "\n") - -;(define m (dbus-proxy "SomeMethod" "org.equinoxproject.Demo" "/org/equinoxproject/Demo" "session")) -;(m "foo" "baz" "taz"): - -(define l (re-split "[ \t_]+" "this_is\tsample string that should be tokenized ")) -(for i in l - (print i "\n") -) - -;(print (first (re-match "-" "some-sample-string" 0)) "\n") -; -;(define pos (re-match "http://(.*):" "http://www.google.com:8080")) -;(print pos "\n") -;(set! i (first pos)) -; -;(while [< i (first (rest pos))] -; (print (string-ref "http://www.google.com:8080" i) "\n") -; (set! i (+ i 1)) -;) -;; -;(set! l (re-split "fooxxxbaz")) -;(for i in l -; (print i "\n") -;) - - -;(print (re-replace "-" "@this--is-foo" "

") "\n") - -;(println "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=") -;(println " Capone System 0.1 ") -;(println "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=") diff --git a/tools/capone/test/if-not.ss b/tools/capone/test/if-not.ss deleted file mode 100644 index 0400153..0000000 --- a/tools/capone/test/if-not.ss +++ /dev/null @@ -1,18 +0,0 @@ -;; -;; if-not expression -;; - -(load "../lib/common.ss") - -(ut-add-test - "Check 'if-not' expression" - (begin - (define a 0) - (define b 1) - - (and - (if-not a #f #t) - (if-not (= a 3) #t #f) - (if-not (= b 1) #f #t) - (if-not (= b 0) #t #f) -))) diff --git a/tools/capone/test/main.ss b/tools/capone/test/main.ss deleted file mode 100644 index f8fce2f..0000000 --- a/tools/capone/test/main.ss +++ /dev/null @@ -1,23 +0,0 @@ -;; -;; main unittest driver for capone -;; - -;; Since 'utest.ss' is included here first, before -;; code that calls functions from it, the same code does -;; not need to include it again. -;; -;; Otherwise, global counter in 'utest.ss' will be set to -;; empty list within each call and that is what we do not want -(load "utest.ss") -(load "math.ss") -(load "string.ss") -(load "if-not.ss") - -(ut-println "") -(ut-println " =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=") -(ut-println " Capone Test Suite From Hell ") -(ut-println " Ready to smack that CPU? ") -(ut-println " =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=") -(ut-println "") - -(ut-run-all) diff --git a/tools/capone/test/math.ss b/tools/capone/test/math.ss deleted file mode 100644 index a12a596..0000000 --- a/tools/capone/test/math.ss +++ /dev/null @@ -1,39 +0,0 @@ -;; -;; basic scheme math operators -;; - -(ut-add-test - "Check '+' operator" - (begin - (and - (= 3 (+ 1 2)) - (= 1 (+ 1 0)) - (= 120 (+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) - ))) - -(ut-add-test - "Check '-' operator" - (begin - (and - (= 1 (- 3 2)) - (= -1 (- 1 2)) - (= -248 (- 100 99 98 97 12 13 14 15)) - ))) - -(ut-add-test - "Check '*' operator" - (begin - (and - (= 0 (* 1 0)) - (= 0 (* 0 1 2 3 4 5 6 7 8 9)) - (= 362880 (* 1 2 3 4 5 6 7 8 9)) - ))) - -(ut-add-test - "Check '/' operator" - (begin - (and - (= 2 (/ 4 2)) - (= 40 (/ 80 2)) - (= 2 (/ 1000 10 50)) - ))) diff --git a/tools/capone/test/run-all.sh b/tools/capone/test/run-all.sh deleted file mode 100755 index 05b8c7b..0000000 --- a/tools/capone/test/run-all.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -../src/capone -d ../lib main.ss diff --git a/tools/capone/test/string.ss b/tools/capone/test/string.ss deleted file mode 100644 index 411982b..0000000 --- a/tools/capone/test/string.ss +++ /dev/null @@ -1,125 +0,0 @@ -;; -;; string functions -;; - -(ut-add-test - "Check 'string?' function" - (begin - (and - (string? "sample string") - (not (string? 123)) - (not (string? #\w)) - ))) - -(ut-add-test - "Check 'string=?' function" - (begin - (and - (string=? "sample string" "sample string") - (not (string=? "sample string" "sample String")) - (not (string=? "ssss" "")) - ))) - -(ut-add-test - "Check 'string?' functions" - (begin - (and - (string? "z" "aaaa") - (string>? "fooo" "foo") - (string>? "foo" "asdadad") - (string>? "fooooooooo" "ab") - ))) - -(ut-add-test - "Check 'string<=? and string>=?' functions" - (begin - (and - (string<=? "aaaa" "z") - (string<=? "aaaa" "aaaa") - (string<=? "" "") - (not (string<=? "foo" "asdadad")) - (not (string<=? "fooooooooo" "ab")) - - (string>=? "z" "aaaa") - (string>=? "aaaa" "aaaa") - (string>=? "" "") - (string>=? "foo" "asdadad") - (string>=? "fooooooooo" "ab") - ))) - -(ut-add-test - "Check 'string->list' function" - (begin - (let ((l (string->list "sample string"))) - (and - (= 13 (length l)) - (char=? #\s (car l)) - (char=? #\a (cadr l)) - (char=? #\m (caddr l)) - (char=? #\p (cadddr l)) - )))) - -(ut-add-test - "Check 'list->string' function" - (begin - (let ((s (list->string '(#\s #\a #\m #\p #\l #\e #\space #\s #\t #\r #\i #\n #\g)))) - (string=? s "sample string") - ))) - -(ut-add-test - "Check 'string-length' function" - (begin - (and - (= 18 (string-length "some stupid sample")) - (= 0 (string-length "")) - (= 1 (string-length "a")) - ))) - -;; As I could find from chicken and guile, string-fill! should modify -;; any string, not only one given with (make-string) only, which creates immutable strings -;; -;; This behaviour should be somehow documented and here it is: -;; If we make a string like '(define s "foo")' it will be immutable by default and that -;; can't be changed. On other hand, if we do something like: -;; (define s (make-string 10)) -;; (set! s (string-copy "foo")) -;; 's' will have "foo" value, have length of 3 characters and _will_ be mutable, e.g. -;; '(string-set! s 0 #\m)' will not fail and result will be "moo". -;; -;; Should it be seen as bug? -(ut-add-test - "Check 'string-fill! and make-string' functions [!]" - (begin - (define s (make-string 11)) - (string-fill! s #\o) - (string=? s "ooooooooooo") - )) - -(ut-add-test - "Check 'string-set!' function" - (begin - (define s (make-string 10)) - (set! s (string-copy "abrakadabra abrakadabra")) - (string-set! s 0 #\A) - (string-set! s 1 #\B) - (string-set! s 2 #\A) - (string-set! s 11 #\|) - (string-set! s 22 #\A) - (string=? s "ABAakadabra|abrakadabrA") - ) -) - -(ut-add-test - "Check 'number->string' function" - (begin - (and - (string=? "33" (number->string 33)) - (string=? "1234" (number->string 1234)) - (string=? "0" (number->string 0)) - (string=? "-1234" (number->string -1234)) - ))) diff --git a/tools/capone/test/utest.ss b/tools/capone/test/utest.ss deleted file mode 100644 index 09aa4ee..0000000 --- a/tools/capone/test/utest.ss +++ /dev/null @@ -1,87 +0,0 @@ -;; -;; simple unittest code -;; - -;; Here are stored functions that will be executed. -;; Each of them will be stored as list, function description and it's name -(define *registered-ut-code* '()) - -;; A functions for easier printing -(define (ut-print arg . rest) - (display arg) - (let loop ((rest rest)) - (if (not (null? rest)) - (begin - (display (car rest)) - (loop (cdr rest)))))) - -(define-macro (ut-println . body) - `(ut-print ,@body "\n")) - -;; Register a new function. Function should do some tests -;; and if they are correct it must return '#t' or '#f' if not -(define (ut-add-test-internal description func) - (set! *registered-ut-code* (cons - (list description func) - *registered-ut-code*))) - -;; A macro for easier usage of above function -(define-macro (ut-add-test descr . code) - `(ut-add-test-internal ,descr - (lambda () - ,(car code)))) - -;; Return how many there are tests -(define (ut-num-tests) - (length *registered-ut-code*)) - -(define (compute-percent curr maximum) - (/ (* 100 curr) maximum)) - -;; Calculate number of digits in given number -(define (num-digits n) - (let loop ((n n) - (ret 1)) - (if (and - (< n 10) - (> n -10)) - ret - (loop (/ n 10) (+ ret 1))))) - -;; Alling dots according to curr and maximum relationship -(define (print-dots curr maxnum) - ;; let we start with at least 3 dots - (ut-print "...") - - (let loop ([start (num-digits curr)] - [end (num-digits maxnum)]) - (if (>= start end) - #t - (begin - (ut-print ".") - (loop (+ 1 start) end))))) - -;; Run 'func' on each test. 'func' must have two parameters; first will -;; be functor and second will be it's description -(define (ut-run-all) - (set! *registered-ut-code* (reverse *registered-ut-code*)) - (define i 1) - (define ntests (ut-num-tests)) - - (for-each - (lambda (x) - (ut-print "[" i "/" ntests "]") - - ;; print aligning dots - (print-dots i ntests) - - (if ((cadr x)) - (ut-print "\033[32m[PASSED]\033[0m: ") - (ut-print "\033[31m[FAILED]\033[0m: ")) - - ;; print description - (ut-println (car x)) - - (set! i (+ i 1))) - *registered-ut-code*) -)