This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/5_7.ss
2022-07-29 15:12:07 +02:00

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