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

;;; Modules
;;; Copyright (C) 2024 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 boot-primitives-module!)
  (import (hoot modules)
          (hoot errors)
          (hoot primitives))

  (define (install-primitive-definitions! m)
    (define-syntax-rule (install! prim v)
      (module-define! m 'prim v #:mutable? #f))
    (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))))

    (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/2! %call-with-values)
    (install/1! %car)
    (install/1! %cdr)
    (install/1! %ceiling)
    (install/1! %char->integer)
    (install/1! %char?)
    (install/1! %complex?)
    (install/2! %cons)
    ;(install/3! %dynamic-wind)
    (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/2! %logbit?)
    (install/2! %logior)
    ;(install/1! %lognot)
    (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/1! %string-utf8-length)
    (install/1! %string?)
    ;(install/2! %struct-ref)
    ;(install/3! %struct-set!)
    (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:
    ;(vector . %vector)
    ;(error . %error)
    ;(cons* %cons*)
    ;(the-eof-object . %the-eof-object)
    ;%inline-wasm, %wasm-import, include-from-path...
    ;; FIXME: make-struct -> allocate-struct + struct-init!
    #t)
  
  (define (boot-primitives-module! mod)
    (check-type mod module? 'module-local-variable)
    (define root (resolve-module mod '()))
    (unless (submodule-ref root '(hoot primitives))
      (let ((m (submodule-define! root '(hoot primitives))))
        (install-primitive-definitions! m)))
    (%values)))