mirror/ede
1
0
Fork 0
mirror of https://github.com/edeproject/ede.git synced 2023-08-10 21:13:03 +03:00
Code Issues Projects Releases Wiki Activity

Moving capone scheme in branches

Browse Source
This commit is contained in:
Sanel Zukan 2009-02-19 08:35:33 +00:00
parent e2fe8e90ab
commit 06e789d6bf
33 changed files with 0 additions and 17742 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
tools/capone/Jamfile
View File

@ -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 ;

602
tools/capone/lib/capone.init
View File

@ -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>=? 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))
(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>=? 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 (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)

182
tools/capone/lib/common.ss
View File

@ -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))

28
tools/capone/src/Jamfile
View File

@ -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 ;

56
tools/capone/src/bbb.ss
View File

@ -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")

141
tools/capone/src/capone-doc
View File

@ -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 <<EOL
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<title>$_[0]</title>
<style type="text/css">
body {
margin: 0;
padding: 0;
text-align: center;
}
.content {
margin: 0 auto;
padding: 10px 0 0 0;
width: 83%;
text-align: left;
}
h5.function {
margin: 5px 0 5px 0;
padding: 0;
color: #527bbd;
font-weight: bold;
font-size: 120%;
}
h5.example {
margin: 0;
padding-bottom: 0.3em;
}
pre {
margin: 0;
padding: 0.6em 0.2em 0.2em 0.2em;
color: black;
background: #f4f4f4;
border: 1px solid silver;
}
.footer {
padding: 20px 0 10px 0;
text-align: center;
font-size: 80%;
}
</style>
</head>
<body>
<div class="content">
EOL
}
sub write_epilog {
print <<EOL
</div> <!-- content -->
<div class="footer">generated with capone-doc</div>
</body>
</html>
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(<INFILE>) {
# find markers
if(/^;;=/) {
if($in_block eq 0) {
print "<div class=\"segment\">\n";
$in_block = 1;
} else {
print "</div> <!-- segment -->\n";
print "<br />\n";
$in_block = 0;
}
# strip them
s/;;=(.*)$//;
}
if($in_block eq 1) {
# strip comments
s/;;\s*\n$/<br \/>\n/;
s/;;//;
# \code and \endcode
s/\\code/ <h5 class="example">Example:<\/h5>\n<pre>/;
s/\\endcode/ <\/pre>/;
# \func
s/\\func (.*)/ <h5 class="function">$1<\/h5>/;
# \param
s/\\param (.*)/ <b>parameter:<\/b> $1<br \/>/;
# \return
s/\\return (.*)/ <b>returns:<\/b> $1<br \/>/;
# \syntax
s/\\syntax (.*)/ <b>syntax:<\/b> <i>$1<\/i><br \/>/;
# \br
s/\\br/<br \/>/g;
# \center
s/\\center (.*)$/<center>$1<\/center>/;
# grok everything out
print $_;
}
}
&write_epilog;
}
&main;

158
tools/capone/src/capone.cpp
View File

@ -1,158 +0,0 @@
#include <stdio.h>
#include <string.h>
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;
}

90
tools/capone/src/dbus.cpp
View File

@ -1,90 +0,0 @@
#include <string.h>
#include <stdio.h>
#include <edelib/EdbusConnection.h>
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 <service> <interface> <path> <"system|session"> <message>*/
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));
}

6
tools/capone/src/dbus.h
View File

@ -1,6 +0,0 @@
#ifndef __DBUS_H__
#define __DBUS_H__
void register_dbus_functions(scheme* sc);
#endif

139
tools/capone/src/dynload.c
View File

@ -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 <string.h>
#include <stdio.h>
#include <stdlib.h>
#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 <windows.h>
#else
typedef void *HMODULE;
typedef void (*FARPROC)();
#define SUN_DL
#include <dlfcn.h>
#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 <dlfcn.h>
#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);
}

12
tools/capone/src/dynload.h
View File

@ -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

7
tools/capone/src/foo.ss
View File

@ -1,7 +0,0 @@
(define (foo a b)
;;"Retrun the sum of it's arguments"
(+ a b))
(display (foo 3 2))
(newline)

192
tools/capone/src/opdefines.h
View File

@ -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

183
tools/capone/src/pcre/pcre-chartables.c
View File

@ -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 */

108
tools/capone/src/pcre/pcre-config.h
View File

@ -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 <stddef.h> 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 */

752
tools/capone/src/pcre/pcre-internal.h
View File

@ -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 <ph10@cam.ac.uk>
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 <ctype.h>
#include <limits.h>
#include <setjmp.h>
#include <stdarg.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#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 */

9197
tools/capone/src/pcre/pcre.c
View File

File diff suppressed because it is too large Load Diff

239
tools/capone/src/pcre/pcre.h
View File

@ -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 <stdlib.h>
/* 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 */

288
tools/capone/src/re.cpp
View File

@ -1,288 +0,0 @@
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
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 <pattern> <string>) => ("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 <pattern> <string> <optional-start-pos>) => (<match-start> <match-len>)
* 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 <pattern> <target> <replacement> <optional-false>) => <replaced-target>
* if given <optional-false>, only first pattern will be replaced
* or <target> 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));
}

6
tools/capone/src/re.h
View File

@ -1,6 +0,0 @@
#ifndef __RE_H__
#define __RE_H__
void register_re_functions(scheme* sc);
#endif

189
tools/capone/src/scheme-private.h
View File

@ -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

4454
tools/capone/src/scheme.c
View File

File diff suppressed because it is too large Load Diff

221
tools/capone/src/scheme.h
View File

@ -1,221 +0,0 @@
/* SCHEME.H */
#ifndef _SCHEME_H
#define _SCHEME_H
#include <stdio.h>
/*
* 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

109
tools/capone/src/sys.cpp
View File

@ -1,109 +0,0 @@
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <time.h>
#include <edelib/Missing.h>
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 <what>) => <string>
* returns environment value for <what>; if <what> 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));
}

6
tools/capone/src/sys.h
View File

@ -1,6 +0,0 @@
#ifndef __SYS_H__
#define __SYS_H__
void register_sys_functions(scheme* sc);
#endif

19
tools/capone/src/tok.ss
View File

@ -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")

50
tools/capone/src/xxx.ss
View File

@ -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 "</" "<a href=\"foo\">foo</a>xxx<a href=\"baz\">baz</a>"))
;(for i in l
; (print i "\n")
;)
;(print (re-replace "-" "@this--is-foo" "<p>") "\n")
;(println "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=")
;(println " Capone System 0.1 ")
;(println "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=")

18
tools/capone/test/if-not.ss
View File

@ -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)
)))

23
tools/capone/test/main.ss
View File

@ -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)

39
tools/capone/test/math.ss
View File

@ -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))
)))

3
tools/capone/test/run-all.sh
View File

@ -1,3 +0,0 @@
#!/bin/sh
../src/capone -d ../lib main.ss

125
tools/capone/test/string.ss
View File

@ -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<? and string>?' functions"
(begin
(and
(string<? "aaaa" "z")
(string<? "foo" "fooo")
(not (string<? "foo" "asdadad"))
(not (string<? "fooooooooo" "ab"))
(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))
)))

87
tools/capone/test/utest.ss
View File

@ -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*)
)