Changeset 8397 in project


Ignore:
Timestamp:
02/12/08 04:12:52 (12 years ago)
Author:
Kon Lovett
Message:

Added chardefs make procedure.

Location:
chicken/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/buildsvnrevision

    r8390 r8397  
    1 8384
     18393
  • chicken/trunk/regex.scm

    r8390 r8397  
    3737  (bound-to-procedure
    3838    ;; Forward reference
    39     make-anchored-pattern
     39    regex-chardef-table? make-anchored-pattern
    4040    ;; Imports
    4141    get-output-string open-output-string
     
    4444    char=? char-alphabetic? char-numeric? char->integer
    4545    set-finalizer!
     46    ##sys#pointer?
    4647    ##sys#slot ##sys#setslot ##sys#size
    4748    ##sys#make-structure ##sys#structure?
     
    5051    ##sys#write-char-0 )
    5152  (export
    52     ##sys#regex-chardef-table?
     53    regex-chardef-table? regex-chardef-table
    5354    regexp? regexp regexp*
    5455    regexp-optimize
    55     regex-chardef-table?
    5656    make-anchored-pattern
    5757    string-match string-match-positions string-search string-search-positions
     
    8787    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
    8888 [else
     89  (define (##sys#check-chardef-table x loc)
     90    (unless (regex-chardef-table? x)
     91      (##sys#error loc "invalid character definition tables structure" x) ) )
    8992  (declare
    90     (export
    91       ##sys#check-chardef-table)
    9293    (bound-to-procedure
    9394      ;; Imports
    9495      ##sys#check-string ##sys#check-list ##sys#check-exact ##sys#check-vector
    95       ##sys#check-structure ##sys#check-symbol ##sys#check-blob ##sys#check-integer)
    96     (emit-exports "regex.exports")) ] )
     96      ##sys#check-structure ##sys#check-symbol ##sys#check-blob ##sys#check-integer )
     97    (export
     98      ##sys#check-chardef-table )
     99    (emit-exports "regex.exports") ) ] )
    97100
    98101
     
    108111
    109112;;; From unit lolevel:
     113
     114(define-inline (%tag-pointer ptr tag)
     115  (let ([tp (##sys#make-tagged-pointer tag)])
     116    (##core#inline "C_copy_pointer" ptr tp)
     117    tp ) )
    110118
    111119(define-inline (%tagged-pointer? x tag)
     
    113121       (##core#inline "C_taggedpointerp" x)
    114122       (eq? tag (##sys#slot x 1)) ) )
    115 
    116 
    117 ;;; Character Definition Tables:
    118 ;;; See unit regex-extras
    119 
    120 (define (##sys#regex-chardef-table? x)
    121   (%tagged-pointer? x 'chardef-table) )
    122 
    123 (cond-expand
    124  [unsafe]
    125  [else
    126   (define (##sys#check-chardef-table x loc)
    127     (unless (##sys#regex-chardef-table? x)
    128       (##sys#error loc "invalid character definition tables structure" x) ) ) ] )
    129123
    130124
     
    200194(define-inline (%regexp-options-set! rx options)
    201195  (##sys#setslot rx 3 options) )
     196
     197
     198;;; Character Definition Tables:
     199
     200;; The minimum necessary to handle chardef table parameters.
     201
     202;;
     203
     204(define (regex-chardef-table? x)
     205  (%tagged-pointer? x 'chardef-table) )
     206
     207;; Get a character definitions tables structure for the current locale.
     208
     209(define regex-chardef-table
     210  (let ([re-maketables
     211          (foreign-lambda* (c-pointer unsigned-char) ()
     212            "return (pcre_maketables ());")]
     213        [re-make-chardef-table-type
     214          (lambda (tables)
     215            (%tag-pointer tables 'chardef-table) ) ] )
     216    (lambda (#!optional tables)
     217      ; Using this to type tag a ref is a bit of a hack but beats
     218      ; having another public variable.
     219      (if tables
     220          ; then existing reference so just tag it
     221          (if (##sys#pointer? tables)
     222              (re-make-chardef-table-type tables)
     223              (##sys#signal-hook #:type-error 'regex-chardef-table
     224               "bad argument type - not a pointer" tables) )
     225          ; else make a new chardef tables
     226          (let ([tables (re-maketables)])
     227            (if tables
     228                (let ([tables (re-make-chardef-table-type tables)])
     229                  (set-finalizer! tables re-finalizer)
     230                  tables )
     231                (##sys#error-hook 6 'regex-chardef-table) ) ) ) ) ) )
    202232
    203233
Note: See TracChangeset for help on using the changeset viewer.