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/csug/priminfo.ss

63 lines
2.2 KiB
Scheme
Raw Normal View History

2022-07-29 15:12:07 +02:00
;;; priminfo.ss
;;; Copyright 2005-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.
(module priminfo (primvec get-libraries)
(define prim-db (make-eq-hashtable))
(define primvec
(lambda ()
(hashtable-keys prim-db)))
(define get-libraries
(lambda (name)
(or (eq-hashtable-ref prim-db name #f)
(errorf #f "unknown primitive ~s" name))))
(define put-priminfo!
(lambda (prim lib*)
(when (eq-hashtable-contains? prim-db prim)
(warning 'define-symbol-type "extra entry for ~s" prim))
(eq-hashtable-set! prim-db prim lib*)))
(define-syntax define-symbol-flags*
(lambda (x)
(syntax-case x (libraries)
[(k ([libraries lib ...] [flags flag ...] ignore ...) entry ...)
(or (memq 'system (datum (flag ...)))
(memq 'system-keyword (datum (flag ...))))
#'(void)]
[(k ([libraries] ignore ...) entry ...)
#'(k ([libraries (chezscheme)] ignore ...) entry ...)]
[(_ ([libraries lib ...] ignore ...) entry ...)
(if (syntax-case #'(lib ...) (rnrs)
[((rnrs x ...) y ...) #t]
[_ #f])
#'(void)
(let ()
(define do-entry
(lambda (x)
(syntax-case x ()
[((prefix prim) ignore ...)
(and (identifier? #'prefix) (identifier? #'prim))
#'(put-priminfo! 'prim '(lib ...))]
[(prim ignore ...)
(identifier? #'prim)
#'(put-priminfo! 'prim '(lib ...))])))
#`(begin #,@(map do-entry #'(entry ...)))))])))
(include "../s/primdata.ss")
)