207 lines
7.7 KiB
Scheme
207 lines
7.7 KiB
Scheme
|
;;; 5_7.ss
|
||
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
;;; symbol functions
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define property-list
|
||
|
|
(lambda (s)
|
||
|
|
(unless (symbol? s)
|
||
|
|
($oops 'property-list "~s is not a symbol" s))
|
||
|
|
(list-copy ($symbol-property-list s))))
|
||
|
|
|
||
|
|
(define putprop
|
||
|
|
(lambda (s p v)
|
||
|
|
(if (symbol? s)
|
||
|
|
(let pt ([pl ($symbol-property-list s)])
|
||
|
|
(cond
|
||
|
|
[(null? pl)
|
||
|
|
($set-symbol-property-list! s
|
||
|
|
(cons p (cons v ($symbol-property-list s))))]
|
||
|
|
[(eq? (car pl) p)
|
||
|
|
(set-car! (cdr pl) v)]
|
||
|
|
[else (pt (cdr (cdr pl)))]))
|
||
|
|
($oops 'putprop "~s is not a symbol" s))))
|
||
|
|
|
||
|
|
(define remprop
|
||
|
|
(lambda (s p)
|
||
|
|
(if (symbol? s)
|
||
|
|
(let pt ([pl ($symbol-property-list s)] [prev #f])
|
||
|
|
(cond
|
||
|
|
[(null? pl) (void)]
|
||
|
|
[(eq? (car pl) p)
|
||
|
|
(if prev
|
||
|
|
(set-cdr! prev (cdr (cdr pl)))
|
||
|
|
($set-symbol-property-list! s (cdr (cdr pl))))]
|
||
|
|
[else (pt (cdr (cdr pl)) (cdr pl))]))
|
||
|
|
($oops 'remprop "~s is not a symbol" s))))
|
||
|
|
|
||
|
|
(define $sgetprop
|
||
|
|
(lambda (s p d)
|
||
|
|
(unless (symbol? s) ($oops '$sgetprop "~s is not a symbol" s))
|
||
|
|
(let gt ([pl ($system-property-list s)])
|
||
|
|
(if (null? pl)
|
||
|
|
d
|
||
|
|
(if (eq? (car pl) p)
|
||
|
|
(car (cdr pl))
|
||
|
|
(gt (cdr (cdr pl))))))))
|
||
|
|
|
||
|
|
(define $sputprop
|
||
|
|
(lambda (s p v)
|
||
|
|
(unless (symbol? s) ($oops '$sputprop "~s is not a symbol" s))
|
||
|
|
(let ((plist ($system-property-list s)))
|
||
|
|
(let pt ([pl plist])
|
||
|
|
(if (null? pl)
|
||
|
|
($set-system-property-list! s (cons p (cons v plist)))
|
||
|
|
(if (eq? (car pl) p)
|
||
|
|
(set-car! (cdr pl) v)
|
||
|
|
(pt (cdr (cdr pl)))))))))
|
||
|
|
|
||
|
|
(define $sremprop
|
||
|
|
(lambda (s p)
|
||
|
|
(unless (symbol? s) ($oops '$sremprop "~s is not a symbol" s))
|
||
|
|
(let rp ([pl ($system-property-list s)] [prev #f])
|
||
|
|
(unless (null? pl)
|
||
|
|
(if (eq? (car pl) p)
|
||
|
|
(if prev
|
||
|
|
(set-cdr! prev (cdr (cdr pl)))
|
||
|
|
($set-system-property-list! s (cdr (cdr pl))))
|
||
|
|
(rp (cdr (cdr pl)) (cdr pl)))))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(eval-when (compile) (optimize-level 3))
|
||
|
|
|
||
|
|
(let ([prefix "g"] [count 0])
|
||
|
|
(define generate-unique-name
|
||
|
|
; a-z must come first in alphabet. separator must not be in alphabet.
|
||
|
|
(let ([suffix 0])
|
||
|
|
(define unique-id (foreign-procedure "(cs)unique_id" () scheme-object))
|
||
|
|
(define (make-session-key)
|
||
|
|
(define alphabet "abcdefghijklmnopqrstuvwxyz0123456789")
|
||
|
|
(define separator #\-)
|
||
|
|
(define b (string-length alphabet))
|
||
|
|
(define digit->char (lambda (n) (string-ref alphabet n)))
|
||
|
|
(list->string
|
||
|
|
(let loop ([n (unique-id)] [a (list separator)])
|
||
|
|
(if (< n b)
|
||
|
|
; ensure name starts with letter. assumes a-z first in alphabet.
|
||
|
|
(if (< n 26)
|
||
|
|
(cons (digit->char n) a)
|
||
|
|
(cons* (string-ref alphabet 0) (digit->char n) a))
|
||
|
|
(loop (quotient n b) (cons (digit->char (remainder n b)) a))))))
|
||
|
|
(define (session-key)
|
||
|
|
(or $session-key
|
||
|
|
(let ([k (make-session-key)])
|
||
|
|
(set! $session-key k)
|
||
|
|
(set! suffix -1)
|
||
|
|
k)))
|
||
|
|
(lambda ()
|
||
|
|
(define alphabet "0123456789")
|
||
|
|
(define b (string-length alphabet))
|
||
|
|
(define digit->char (lambda (n) (string-ref alphabet n)))
|
||
|
|
(let* ([k (session-key)] [n (string-length k)])
|
||
|
|
(set! suffix (fx+ suffix 1))
|
||
|
|
(let f ([i 0])
|
||
|
|
(if (fx= i n)
|
||
|
|
(let g ([suffix suffix] [n (fx+ n 1)])
|
||
|
|
(if (< suffix b)
|
||
|
|
(let ([s (make-string n)])
|
||
|
|
(string-set! s i (digit->char suffix))
|
||
|
|
s)
|
||
|
|
(let ([s (g (quotient suffix b) (fx+ n 1))])
|
||
|
|
(string-set! s (fx+ i (fx- (string-length s) n))
|
||
|
|
(digit->char (remainder suffix b)))
|
||
|
|
s)))
|
||
|
|
(let ([s (f (fx+ i 1))])
|
||
|
|
(string-set! s i (string-ref k i))
|
||
|
|
s)))))))
|
||
|
|
(define generate-pretty-name
|
||
|
|
(lambda ()
|
||
|
|
(let ([count (let ([n count]) (set! count (+ n 1)) n)]
|
||
|
|
[prefix prefix])
|
||
|
|
(if (and (string? prefix) (fixnum? count))
|
||
|
|
(let ([n1 (string-length prefix)])
|
||
|
|
(let l1 ([n (fx+ n1 1)] [d 10])
|
||
|
|
(if (fx> d count)
|
||
|
|
(let ([s (make-string n)])
|
||
|
|
(let l2 ([i (fx- n1 1)])
|
||
|
|
(unless (fx< i 0)
|
||
|
|
(string-set! s i (string-ref prefix i))
|
||
|
|
(l2 (fx- i 1))))
|
||
|
|
(let l3 ([i (fx- n 1)] [q count])
|
||
|
|
(unless (fx< i n1)
|
||
|
|
(string-set! s i
|
||
|
|
(string-ref "0123456789" (fxremainder q 10)))
|
||
|
|
(l3 (fx- i 1) (fxquotient q 10))))
|
||
|
|
s)
|
||
|
|
(l1 (fx+ n 1) (fx* d 10)))))
|
||
|
|
(parameterize ([print-radix 10])
|
||
|
|
(format "~a~a" prefix count))))))
|
||
|
|
(define $strings->gensym
|
||
|
|
(foreign-procedure "(cs)s_strings_to_gensym"
|
||
|
|
(scheme-object scheme-object)
|
||
|
|
scheme-object))
|
||
|
|
(set! $gensym->pretty-name
|
||
|
|
(lambda (x)
|
||
|
|
(with-tc-mutex
|
||
|
|
(cond
|
||
|
|
[($symbol-name x) => cdr] ; someone beat us to it
|
||
|
|
[else
|
||
|
|
(let ([name (generate-pretty-name)])
|
||
|
|
($set-symbol-name! x (cons #f name))
|
||
|
|
name)]))))
|
||
|
|
(set-who! gensym->unique-string
|
||
|
|
(lambda (sym)
|
||
|
|
(unless (symbol? sym) ($oops who "~s is not a gensym" sym))
|
||
|
|
(let ([name ($symbol-name sym)])
|
||
|
|
(or (and (pair? name) (car name)) ; get out quick if name already recorded
|
||
|
|
(begin
|
||
|
|
(unless (or (not name) (pair? name)) ($oops who "~s is not a gensym" sym))
|
||
|
|
(with-tc-mutex
|
||
|
|
; grab name again once safely inside the critical section
|
||
|
|
(let ([name ($symbol-name sym)])
|
||
|
|
(if (not name)
|
||
|
|
(let ([uname (generate-unique-name)])
|
||
|
|
($set-symbol-name! sym
|
||
|
|
(cons uname (generate-pretty-name)))
|
||
|
|
($intern-gensym sym)
|
||
|
|
uname)
|
||
|
|
(or (car name)
|
||
|
|
(let ([uname (generate-unique-name)])
|
||
|
|
(set-car! name uname)
|
||
|
|
($intern-gensym sym)
|
||
|
|
uname))))))))))
|
||
|
|
(set! gensym-prefix
|
||
|
|
(case-lambda
|
||
|
|
[() prefix]
|
||
|
|
[(x) (set! prefix x)]))
|
||
|
|
(set! gensym-count
|
||
|
|
(case-lambda
|
||
|
|
[() count]
|
||
|
|
[(x)
|
||
|
|
(unless (and (or (fixnum? x) (bignum? x)) (>= x 0))
|
||
|
|
($oops 'gensym-count "~s is not a nonnegative integer" x))
|
||
|
|
(set! count x)]))
|
||
|
|
(set-who! gensym
|
||
|
|
(case-lambda
|
||
|
|
[() (#3%gensym)]
|
||
|
|
[(pretty-name)
|
||
|
|
(unless (string? pretty-name) ($oops who "~s is not a string" pretty-name))
|
||
|
|
(#3%gensym pretty-name)]
|
||
|
|
[(pretty-name unique-name)
|
||
|
|
(unless (string? pretty-name) ($oops who "~s is not a string" pretty-name))
|
||
|
|
(unless (string? unique-name) ($oops who "~s is not a string" unique-name))
|
||
|
|
($strings->gensym pretty-name unique-name)])))
|