120 lines
4.7 KiB
Racket
120 lines
4.7 KiB
Racket
; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
; Copyright (C) 2010-2021 Tony Garnock-Jones <tonygarnockjones@gmail.com>
|
|
|
|
#lang racket/base
|
|
|
|
(provide (rename-out [module-begin #%module-begin])
|
|
activate
|
|
require/activate
|
|
current-ground-dataspace
|
|
current-activated-modules
|
|
begin-for-declarations ;; TODO: this seems like a horrible hack
|
|
(except-out (all-from-out racket/base) #%module-begin sleep)
|
|
(all-from-out racket/match)
|
|
(all-from-out "main.rkt")
|
|
(for-syntax (all-from-out racket/base)))
|
|
|
|
(require racket/match)
|
|
(require "main.rkt")
|
|
(require (for-syntax racket/base syntax/kerncase))
|
|
|
|
(define-syntax (activate stx)
|
|
(syntax-case stx ()
|
|
[(_ module-path ...)
|
|
(syntax/loc stx
|
|
(begin
|
|
(let ()
|
|
(local-require (submod module-path syndicate-main))
|
|
(activate!))
|
|
...))]))
|
|
|
|
(define-syntax (require/activate stx)
|
|
(syntax-case stx ()
|
|
[(_ module-path ...)
|
|
(syntax/loc stx
|
|
(begin
|
|
(require module-path ...)
|
|
(activate module-path ...)))]))
|
|
|
|
(define-syntax-rule (begin-for-declarations decl ...)
|
|
(begin decl ...))
|
|
|
|
(define current-ground-dataspace (make-parameter #f))
|
|
(define current-activated-modules (make-parameter #f))
|
|
|
|
(define-syntax (module-begin stx)
|
|
(unless (eq? (syntax-local-context) 'module-begin)
|
|
(raise-syntax-error #f "allowed only around a module body" stx))
|
|
(syntax-case stx ()
|
|
[(_ forms ...)
|
|
(let ()
|
|
|
|
(define (accumulate-actions activation-forms final-forms forms)
|
|
(cond
|
|
[(null? forms)
|
|
(define final-stx
|
|
#`(#%module-begin
|
|
;----------------------------------------
|
|
; The final module has three pieces:
|
|
; - a `syndicate-main` submodule, for activation
|
|
; - a `main` submodule, for programs
|
|
; - actual definitions, for everything else.
|
|
; The `main` submodule is split into two pieces,
|
|
; in order to initialise defaults that can then
|
|
; be overridden by the module being compiled.
|
|
|
|
(module+ syndicate-main
|
|
(provide activate!* activate!)
|
|
(define (activate!*)
|
|
#,@(reverse activation-forms)
|
|
(void))
|
|
(define (activate!)
|
|
(when (not (hash-has-key? (current-activated-modules) activate!*))
|
|
(hash-set! (current-activated-modules) activate!* #t)
|
|
(activate!*))))
|
|
|
|
(module+ main (current-ground-dataspace run-ground))
|
|
|
|
#,@(reverse final-forms)
|
|
|
|
(module+ main
|
|
(require (submod ".." syndicate-main))
|
|
(parameterize ((current-activated-modules (make-hasheq)))
|
|
((current-ground-dataspace) activate!)))
|
|
|
|
;----------------------------------------
|
|
))
|
|
;;(pretty-print (syntax->datum final-stx))
|
|
final-stx]
|
|
|
|
[else
|
|
(syntax-case (local-expand (car forms)
|
|
'module
|
|
(append (list #'module+
|
|
#'begin-for-declarations)
|
|
(kernel-form-identifier-list))) ()
|
|
[(head rest ...)
|
|
(cond
|
|
[(free-identifier=? #'head #'begin)
|
|
(accumulate-actions activation-forms
|
|
final-forms
|
|
(append (syntax->list #'(rest ...)) (cdr forms)))]
|
|
[(ormap (lambda (i) (free-identifier=? #'head i))
|
|
(syntax->list #'(define-values define-syntaxes begin-for-syntax
|
|
module module* module+
|
|
#%module-begin
|
|
#%require #%provide
|
|
begin-for-declarations)))
|
|
(accumulate-actions activation-forms
|
|
(cons (car forms) final-forms)
|
|
(cdr forms))]
|
|
[else
|
|
(accumulate-action (car forms) activation-forms final-forms (cdr forms))])]
|
|
[non-pair-syntax
|
|
(accumulate-action (car forms) activation-forms final-forms (cdr forms))])]))
|
|
|
|
(define (accumulate-action action activation-forms final-forms remaining-forms)
|
|
(accumulate-actions (cons action activation-forms) final-forms remaining-forms))
|
|
|
|
(accumulate-actions '() '() (syntax->list #'(forms ...))))]))
|