75 lines
1.8 KiB
Scheme
75 lines
1.8 KiB
Scheme
;;
|
|
;; util-tag.scm
|
|
;;
|
|
;; Implementation of data structure tags.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit util-tag))
|
|
|
|
(import duck)
|
|
|
|
(module*
|
|
util-tag
|
|
#:doc ("A unifying module for compound data structures tagging.")
|
|
(
|
|
make-tag
|
|
util-tag-make
|
|
)
|
|
|
|
(import scheme
|
|
(chicken string)
|
|
(chicken random))
|
|
|
|
;; Syntactic wrapper to allow easy tag creation
|
|
(define-syntax/doc make-tag
|
|
("* ```tag``` - unquoted symbol to base the tag on
|
|
|
|
Creates a unique and collision free symbol to identify compound data
|
|
structures based on lists and pairs.")
|
|
(syntax-rules ()
|
|
((_ tag)
|
|
(util-tag-make 'tag))))
|
|
|
|
;; Creates a tag symbol based on symbol
|
|
(define (util-tag-make sym)
|
|
(string->symbol
|
|
(string-intersperse
|
|
(cons
|
|
(list->string
|
|
(map
|
|
char-upcase
|
|
(string->list
|
|
(symbol->string sym))))
|
|
(cons
|
|
"-"
|
|
(map (lambda (n)
|
|
(substring
|
|
(number->string
|
|
(+ 256 (char->integer n))
|
|
16)
|
|
1))
|
|
(string->list
|
|
(random-bytes
|
|
(make-string 8))))))
|
|
"")))
|
|
|
|
)
|