Guile-hoot/lib/hoot/primitives-module.scm

;;; Modules
;;; Copyright (C) 2024, 2025 Igalia, S.L.
;;;
;;; 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.

;;; Commentary:
;;;
;;; Run-time representation of module trees.
;;;
;;; Code:

(library (hoot primitives-module)
  (export initialize-primitives!)
  (import (hoot modules)
          (hoot errors)
          (hoot primitives))

  (define (install-primitive-definitions! m)
    (define-syntax-rule (install! prim v)
      (begin
        (module-define! m 'prim v #:mutable? #f)
        (module-export! m 'prim)))
    (define-syntax-rule (install/1! prim)
      (install! prim (lambda (a) (prim a))))
    (define-syntax-rule (install/2! prim)
      (install! prim (lambda (a b) (prim a b))))
    (define-syntax-rule (install/3! prim)
      (install! prim (lambda (a b c) (prim a b c))))
    (define-syntax-rule (install-placeholder! prim)
      (install! prim (lambda args (error "placeholder definition" 'prim))))

    (install/2! %*)
    (install/2! %+)
    (install/2! %-)
    (install/2! %/)
    (install/2! %<)
    (install/2! %<=)
    (install/2! %=)
    (install/2! %>)
    (install/2! %>=)
    (install! %abort-to-prompt %abort-to-prompt)
    (install/1! %abs)
    (install/2! %append)
    (install/2! %ash)
    (install! %atan (case-lambda ((x) (%atan x)) ((x y) (%atan x y))))
    (install/3! %atomic-box-compare-and-swap!)
    (install/1! %atomic-box-ref)
    (install/2! %atomic-box-set!)
    (install/2! %atomic-box-swap!)
    (install/1! %bitvector?)
    (install/1! %box-ref)
    (install/2! %box-set!)
    (install/2! %bytevector-ieee-double-native-ref)
    (install/3! %bytevector-ieee-double-native-set!)
    (install/2! %bytevector-ieee-single-native-ref)
    (install/3! %bytevector-ieee-single-native-set!)
    (install/1! %bytevector-length)
    (install/2! %bytevector-s16-native-ref)
    (install/3! %bytevector-s16-native-set!)
    (install/2! %bytevector-s32-native-ref)
    (install/3! %bytevector-s32-native-set!)
    (install/2! %bytevector-s64-native-ref)
    (install/3! %bytevector-s64-native-set!)
    (install/2! %bytevector-s8-ref)
    (install/3! %bytevector-s8-set!)
    (install/2! %bytevector-u16-native-ref)
    (install/3! %bytevector-u16-native-set!)
    (install/2! %bytevector-u32-native-ref)
    (install/3! %bytevector-u32-native-set!)
    (install/2! %bytevector-u64-native-ref)
    (install/3! %bytevector-u64-native-set!)
    (install/2! %bytevector-u8-ref)
    (install/3! %bytevector-u8-set!)
    (install/1! %bytevector?)
    (install/3! %call-with-prompt)
    (install-placeholder! %call-with-values) ; /2
    (install/1! %car)
    (install/1! %cdr)
    (install/1! %ceiling)
    (install/1! %char->integer)
    (install/1! %char?)
    (install/1! %complex?)
    (install/2! %cons)
    (install-placeholder! %dynamic-wind) ; /3
    (install/1! %eof-object?)
    (install/2! %eq?)
    (install/2! %eqv?)
    (install/1! %exact-integer?)
    (install/1! %exact?)
    (install/1! %floor)
    (install/1! %fluid-ref)
    (install/2! %fluid-set!)
    (install/1! %inexact)
    (install/1! %inexact?)
    (install/1! %integer->char)
    (install/1! %integer?)
    (install/1! %keyword->symbol)
    (install/1! %keyword?)
    (install/2! %logand)
    (install-placeholder! %logbit?) ; /2
    (install/2! %logior)
    (install-placeholder! %lognot) ; /1
    (install/2! %logtest)
    (install/2! %logxor)
    (install/1! %make-atomic-box)
    (install/1! %make-box)
    (install/2! %make-vector)
    (install/2! %modulo)
    (install/1! %null?)
    (install/1! %number?)
    (install/1! %pair?)
    (install/1! %procedure?)
    (install/2! %quotient)
    (install/1! %raise-exception)
    (install/1! %rational?)
    (install/1! %real?)
    (install/2! %remainder)
    (install/2! %set-car!)
    (install/2! %set-cdr!)
    (install/1! %sqrt)
    (install/1! %string->symbol)
    (install/1! %string->utf8)
    (install/1! %string-length)
    (install/2! %string-ref)
    (install-placeholder! %string-utf8-length) ; /1
    (install/1! %string?)
    (install-placeholder! %struct-ref) ; /2
    (install-placeholder! %struct-set!) ; /3
    (install/1! %struct-vtable)
    (install/1! %struct?)
    (install/1! %symbol->keyword)
    (install/1! %symbol->string)
    (install/1! %symbol?)
    (install/1! %utf8->string)
    (install! %values %values)
    (install/1! %vector-length)
    (install/2! %vector-ref)
    (install/3! %vector-set!)
    (install/1! %vector?)
    (install/2! %with-dynamic-state)
    (install/3! %with-fluid*)
    (install! apply apply)

    ;; TODO:
    (install-placeholder! %vector)
    (install-placeholder! %error)
    (install-placeholder! %cons*)
    (install-placeholder! %the-eof-object)
    (install-placeholder! %inline-wasm)
    (install-placeholder! %wasm-import)
    (install-placeholder! include-from-path)
    (install-placeholder! guile:syntax-module-bindings)
    #t)
  
  (define (initialize-primitives! mod)
    (install-primitive-definitions! mod)
    (%values)))