Fixed documentation typos in ns.arc.

Fixed documentation typos in ns.arc.

; ns.arc
;
; Ross Angle (rocketnia) 2011
;
; Utilities for managing Racket modules and namespaces.
;
; This library isn't exactly a full Arc module system, but it may be
; useful or instructive to anyone who's inspired to make one. As far
; as I (rocketnia) can tell, the biggest hurdles remaining to making a
; good module system are as follows:
;
;   - Arc macros are a little bit too unhygienic. You can't just
;     import a macro and use it right away, 'cause you also have to
;     import all the variables the macro's expansions could refer to.
;
;   - An Arc module system may need to keep track of other things than
;     global variables, such as type symbols and global table entries.
;     For instance, if two Arc libraries both use types named
;     'special-fn with 'defcall behavior, you get type symbol conflict
;     *and* table entry conflict (the entry for coerce*!fn!special-fn)
;     at the same time.
;
; Parts of these issues can be solved by having all Arc programmers
; follow certain conventions in their code. However, there's a good
; chance the Arc core itself needs to follow those conventions in
; order for the module system to feel seamless, and that may change
; the language to the point that it isn't *really* Arc (whatever that
; means).
;
; This introduces seven types: 'rns, 'anchor, 'ns, 'module, 'rmodule,
; 'modecule, and 'rns-var. The R stands for "Racket," the NS stands
; "namespace", and the MODECULE stands for justice and freedom. For
; each type that starts with R, the non-R version (if there is one)
; automatically converts between Arc variable names and Racket
; variable names so that it's easy to do a certain amount of
; acrobatics with modules and namespaces without acknowledging their
; Racket origins.
;
; Modecules are a bit of an experiment that doesn't seem so useful
; after the fact. Short for "module molecule," they're like modules
; but with one export, which can be imported under various names using
; '{r,}ns-set-modecule. It would be even more useful to have
; '{r,}ns-set-import utilities which take care of renaming using an
; optional "original name" argument. TODO: Implement that.
;
; This library also requires a slight change to ac.scm: Instead of Arc
; global variables being set using 'namespace-set-variable-value!,
; they're now set using 'set!, and the Racket version of an Arc
; command is compiled using 'compile-allow-set!-undefined. See
; 'arc-exec in ac.scm for more details about how this helps.

(require "lib/extend.arc")

(extend type (x) $.namespace?.x
  'rns)

(extend type (x) $.namespace-anchor?.x
  'anchor)

(def ns-racketarc (x)
  (annotate 'ns (list rnsify.x)))

(def ns-arcracket (x)
  (!0:rep nsify.x))

(def global-racketarc (global)
  " Converts a Racket top-level variable name (a symbol) into the name
    the variable is visible as from Arc. "
  (unless $.symbol-interned?.global
    (err "Can't global-racketarc a gensym."))
  (let name string.global
    (unless (begins name "_")
      (err:+ "Can't global-racketarc " (tostring write.global) "."))
    (sym:cut name 1)))

(def global-arcracket (global)
  " Converts an Arc global variable name (a symbol) into the
    corresponding Racket top-level variable name. "
  (unless $.symbol-interned?.global
    (err "Can't global-arcracket a gensym."))
  ac-global-name.global)

(def could-global-racketarc (global)
  (and (isa global 'sym)
       $.symbol-interned?.global
       (begins string.global "_")))

(def safely-global-racketarc (global)
  (when could-global-racketarc.global
    (list global-racketarc.global)))

(def safely-map-global-racketarc (globals)
  (mappend safely-global-racketarc globals))

(def rnsify (x)
  (err:+ "Can't rnsify " (tostring write.x)))

(extend rnsify (x) (isa x 'rns)
  x)

(def nsify (x)
  (err:+ "Can't nsify " (tostring write.x)))

(extend nsify (x) (isa x 'ns)
  x)

(defvar current-rns
  ($.make-derived-parameter $.current-namespace rnsify idfn))

(def call-w/current-rns (rns body)
  (parameterize defvar-impl.current-rns rns
    (body)))

(mac w/current-rns (rns . body)
  `(call-w/current-rns ,rns (fn () ,@body)))

(defvar current-ns ($.make-derived-parameter defvar-impl.current-rns
                     ns-arcracket ns-racketarc))

(def call-w/current-ns (ns body)
  (parameterize defvar-impl.current-ns ns
    (body)))

(mac w/current-ns (ns . body)
  `(call-w/current-ns ,ns (fn () ,@body)))

(eval `($:define-namespace-anchor ,global-arcracket!main-ns-anchor*))

(def anchor-rns ((o anchor main-ns-anchor*))
  $.namespace-anchor->namespace.anchor)

(def anchor-empty-rns ((o anchor main-ns-anchor*))
  $.namespace-anchor->empty-namespace.anchor)

(extend rnsify (x) (isa x 'anchor)
  anchor-rns.x)

(def anchor-ns ((o anchor main-ns-anchor*))
  (ns-racketarc anchor-rns.anchor))

(def anchor-empty-ns ((o anchor main-ns-anchor*))
  (ns-racketarc anchor-empty-rns.anchor))

(extend nsify (x) (isa x 'anchor)
  (ns-racketarc rnsify.x))

(= anon-module-prefix* (string (uniq) '-module-))

(= racket/bare-bones--plain-module-begin (uniq))
(= racket/bare-bones--define (uniq))
(= racket/bare-bones--define-customvar (uniq))
(= racket/bare-bones--quote (uniq))
(= racket/bare-bones--datum (uniq))
(= racket/bare-bones--set (uniq))
(= racket/bare-bones--app (uniq))
(= racket/bare-bones--require (uniq))
(= racket/bare-bones--provide (uniq))

; We define racket/bare-bones, a stripped-down version of racket/base
; where every variable is named as a gensym, just to make sure it's
; possible for our module utilities to define modules which provide
; exports with names like 'define or '#%app which would clash with the
; things used to define those very modules.
;
(eval `($:module racket/bare-bones racket/base
         (require (for-syntax racket/base))
         (define-syntax-rule (define-customvar var getter setter)
           (define-syntax var
             (make-set!-transformer
               (lambda (stx)
                 (syntax-case stx (set!)
                   (id (identifier? #'id) #'(getter))
                   ((set! _ val) #'(setter val)))))))
         (provide (rename-out
                    (#%plain-module-begin
                      ,racket/bare-bones--plain-module-begin)
                    (define     ,racket/bare-bones--define)
                    (define-customvar
                      ,racket/bare-bones--define-customvar)
                    (quote      ,racket/bare-bones--quote)
                    (#%datum    ,racket/bare-bones--datum)
                    (set!       ,racket/bare-bones--set)
                    (#%app      ,racket/bare-bones--app)
                    (#%require  ,racket/bare-bones--require)
                    (#%provide  ,racket/bare-bones--provide)))))

; We manipulate a Racket module as a module path together with a
; Racket namespace the module is registered in.
(def pathed-rmodule (rns path)
  (annotate 'rmodule (list rnsify.rns path)))

(def rmodulify (x)
  (err:+ "Can't rmodulify " (tostring write.x) "."))

(extend rmodulify (x) (isa x 'rmodule)
  x)

(def modulify (x)
  (err:+ "Can't modulify " (tostring write.x) "."))

(extend modulify (x) (isa x 'module)
  x)

(def module-racketarc (rmodule)
  (annotate 'module (list rmodulify.rmodule)))

(def module-arcracket (module)
  (!0:rep modulify.module))

(def rmodule-keys (rmodule)
  (let (rns path)  (rep rmodulify.rmodule)
    (mappend (fn ((phase . exports)) (map car exports))
      ($.call-with-values
        (fn () (w/current-rns rns $.module->exports.path)) join))))

(def module-keys (module)
  (safely-map-global-racketarc:rmodule-keys:module-arcracket
    modulify.module))

(def instantiate-rmodule (rmodule)
  " Instantiates a Racket module by first delving into its internal
    Arc as a combination of a module path and an example namespace
    which has the module attached on that path, and then requiring
    that path in that namespace. "
  (let (rns path) (rep rmodulify.rmodule)
    (w/current-rns rns ($.dynamic-require path ($.void))))
  rmodule)

(def embed-racket/bare-bones (result)
  " Makes a `racket/bare-bones' expression out of the literal value
    `result' by embedding it inside a procedure call. This is
    necessary so that Racket doesn't translate it into immutable
    syntax and back. "
  ($.list racket/bare-bones--app
    (cons racket/bare-bones--datum (fn () result))))

(def make-bare-bones-rmodule (racket-module-body)
  " Makes a Racket module based on `racket/bare-bones' and the given
    Racket list of top-level module expressions. We create the module
    by evaluating a Racket `(module ...) form in the main namespace of
    Arc. The resulting module will have a gensym for a name (even if
    Racket's `current-module-declare-name' would have overridden
    that), and Racket's `compile-enforce-module-constants' parameter
    will be `#f' while the module is being compiled, so that its
    module-level variables can be redefined or assigned to later on. "
  (let name uniq.anon-module-prefix*
    (let expr ($.list 'module name (ac-denil ''racket/bare-bones)
                (cons racket/bare-bones--plain-module-begin
                  racket-module-body))
      (w/current-ns (anchor-ns)
        (let compiled (parameterize
                          $.compile-enforce-module-constants scheme-f
                        $.compile.expr)
          (parameterize $.current-module-declare-name scheme-f
            $.eval.compiled))))
    (pathed-rmodule (anchor-empty-rns) (ac-denil `',name))))

(def make-simple-rmodule binds
  (make-bare-bones-rmodule:ac-denil:mappend
    (fn ((var val))
      (let box $.box.val
        `((,racket/bare-bones--define-customvar ,var
            ,(embed-racket/bare-bones:fn () $.unbox.box)
            ,(embed-racket/bare-bones
               ; NOTE: We would use [] syntax, but that would try to
               ; ssexpand 'set-box!.
               (fn (val) (($ set-box!) box val))))
          (,racket/bare-bones--provide ,var))))
    pair.binds))

(def make-simple-module binds
  (module-racketarc:apply make-simple-rmodule
    (mappend [list (global-arcracket _.0) _.1] pair.binds)))

(mac simple-rmod binds
  `(make-simple-rmodule ,@(mappend [do `(',_.0 ,_.1)] pair.binds)))

(mac simple-mod binds
  `(make-simple-module ,@(mappend [do `(',_.0 ,_.1)] pair.binds)))

(def make-sub-rmodule (rmodule var-test)
  (let (rns path) (rep rmodulify.rmodule)
    (make-bare-bones-rmodule:ac-denil
      `((,racket/bare-bones--require ,path)
        ,@(map [do `(,racket/bare-bones--provide ,_)]
               (keep var-test rmodule-keys.rmodule))))))

(def make-renaming-rmodule (rmodule renamer)
  (let (rns path) (rep rmodulify.rmodule)
    (make-bare-bones-rmodule:ac-denil
      `((,racket/bare-bones--require ,path)
        ,@(map [do `(,racket/bare-bones--provide
                      (rename ,_ ,renamer._))]
               rmodule-keys.rmodule)))))

(extend rnsify (x) (isa x 'rmodule)
  (let (rns path) (rep instantiate-rmodule.x)
    (w/current-rns rns $.module->namespace.path)))

(extend nsify (x) (isa x 'module)
  (ns-racketarc:rnsify module-arcracket.x))

(def expand-w/rmodule (rmodule body)
  (zap instantiate-rmodule rmodule)
  (let (rns path) rep.rmodule
    ; We introduce local variables corresponding to the module's
    ; exports so that the Arc compiler doesn't use 'ac-global-name for
    ; those variables within 'body.
    `(with ,(mappend [do `(,_ nil)] rmodule-keys.rmodule)
       ($:local-require ,path)
       ,@body)))

(def expand-w/module (module body)
  (zap module-arcracket:modulify module)
  (zap make-sub-rmodule module could-global-racketarc)
  (zap make-renaming-rmodule module global-racketarc)
  (expand-w/rmodule module body))

(mac w/rmodule (rmodule . body)
  " Evaluates `rmodule' at expansion time and uses Racket's
    `local-require' to require the resulting module in a local
    scope for `body'. "
  (expand-w/rmodule eval.rmodule body))

(mac w/module (module . body)
  " Evaluates `module' at expansion time and uses Racket's
    `local-require' to require the Arc variables of the resulting
    module in a local scope for `body'. "
  (expand-w/module eval.module body))

(= modecule-var* 'val)  ; This is an Arc variable name.

(def view-modecule (module var)
  (annotate 'modecule (list module var)))

(def make-modecule (val (o var modecule-var*))
  (view-modecule (make-simple-module var val) var))

(def rns-var (var (o default-rns current-rns))
  (case type.var
    sym      (annotate 'rns-var (list var rnsify.default-rns))
    rns-var  var
             (err:+ "Can't rns-var " (tostring write.var))))

(withs (racket-stx [let (var rns) (rep rns-var._)
                     (w/current-rns rns
                       $.namespace-symbol->identifier.var)]
        (top set app datum quote-stx define-syntax)
          (map racket-stx
            '(#%top set! #%app #%datum quote define-syntax))
        embed [$.list app (cons datum (fn () _))])

  (def rns-get (var (o rns current-rns))
    " Gets a variable from a Racket namespace by evaluating it in
      Racket. Actually, it's sent through Racket's 'expand-to-top-form
      so that we can use the core #%top form if necessary rather than
      relying on the namespace itself to have one. "
    (let (var rns) (rep:rns-var var rns)
      (w/current-rns rns
        (let expanded $.expand-to-top-form.var
          ; If the expanded form is an identifier and its binding is
          ; #f (signifying a top-level binding), we use the core #%top
          ; form. Otherwise, we just evaluate it as-is.
          ($.eval:if (and $.identifier?.expanded
                          (no $.identifier-binding.expanded))
            ($.cons top expanded)
            expanded)))))

  (def ns-get (var (o ns current-ns))
    " Gets a variable from a namespace by evaluating it in Racket.
      Actually, it's sent through Racket's 'expand-to-top-form so that
      we can use the core #%top form if necessary rather than relying
      on the namespace itself to have one. "
    (rns-get global-arcracket.var ns-arcracket.ns))

  (def rns-set (var val (o rns current-rns))
    " Sets a variable in a Racket namespace using Racket's 'set!. "
    (let (var rns) (rep:rns-var var rns)
      (w/current-rns rns ($.arc-exec:$.list set var embed.val)))
    val)

  (def ns-set (var val (o ns current-ns))
    " Sets a variable in a namespace using Racket's 'set!. "
    (rns-set global-arcracket.var val ns-arcracket.ns))

  (def rns-ownspace-set (var val (o rns current-rns))
    " Sets a top-level variable in a Racket namespace without changing
      the corresponding identifier mapping to point to that
      variable. "
    (let (var rns) (rep:rns-var var rns)
      (($ namespace-set-variable-value!) var val scheme-f rnsify.rns))
    val)

  (def ns-ownspace-set (var val (o ns current-ns))
    " Sets a top-level variable in a namespace without changing the
      corresponding identifier mapping to point to that variable. "
    (rns-ownspace-set global-arcracket.var val ns-arcracket.ns))

  (def rns-set-own (var val (o rns current-rns))
    " Sets a top-level variable in a Racket namespace and changes the
      corresponding identifier mapping to point to that variable. "
    (let (var rns) (rep:rns-var var rns)
      (($ namespace-set-variable-value!) var val scheme-t rnsify.rns))
    val)

  (def ns-set-own (var val (o ns current-ns))
    " Sets a top-level variable in a namespace and changes the
      corresponding identifier mapping to point to that variable. "
    (rns-set-own global-arcracket.var val ns-arcracket.ns))

  (def rns-set-renamer (observing-var
                        canonical-var (o canonical-rns current-rns))
    " Changes an identifier mapping in a Racket namespace to point to
      a rename transformer. "
    (let (observing-var observing-rns) (rep rns-var.observing-var)
      (ret transformer ($.make-rename-transformer:racket-stx:rns-var
                         canonical-var canonical-rns)
        (w/current-rns observing-rns
          ($.arc-exec:$.list
            define-syntax observing-var embed.transformer)))))

  (def ns-set-renamer (observing-var
                       canonical-var (o canonical-ns current-ns))
    " Changes an identifier mapping in a namespace to point to a
      rename transformer. "
    (rns-set-renamer global-arcracket.observing-var
      global-arcracket.canonical-var ns-arcracket.canonical-ns))

  (def rns-set-modecule (var modecule (o rns current-rns))
    (withs ((var rns) (rep:rns-var var rns)
            (mod modecule-var) rep.modecule
            (mod-rns path) (rep module-arcracket.mod))
      (w/current-rns rns
        ($.namespace-require:$.list 'rename
          path var global-arcracket.modecule-var)))
    modecule)

  (def ns-set-modecule (var modecule (o ns current-ns))
    (rns-set-modecule global-arcracket.var modecule ns-arcracket.ns))
  )

(defcall rns (self var)
  (rns-get var self))

(defcall ns (self var)
  (ns-get var self))

(extend sref (self val . args) (and (isa self 'rns) single.args)
  (rns-set car.args val self))

(extend sref (self val . args) (and (isa self 'ns) single.args)
  (ns-set car.args val self))

(defcall rmodule (self var)
  (rns-get var self))

(defcall module (self var)
  (ns-get var self))

(extend sref (self val . args) (and (isa self 'rmodule) single.args)
  (rns-set car.args val self))

(extend sref (self val . args) (and (isa self 'module) single.args)
  (ns-set car.args val self))

(def make-ns binds
  (ret result (anchor-empty-ns)
    (each (var val) pair.binds
      (ns-set-own var val result))))

(def make-base-ns binds
  (ret result ($.make-base-namespace)
    (each (var val) pair.binds
      (ns-set-own var val result))))

(mac nsobj binds
  `(make-ns ,@(mappend [do `(',_.0 ,_.1)] pair.binds)))

(def rns-keys (rns)
  (copylist:$.namespace-mapped-symbols rnsify.rns))

(def ns-keys (ns)
  (safely-map-global-racketarc:rns-keys ns-arcracket.ns))

; ns.arc
;
; Ross Angle (rocketnia) 2011
;
; Utilities for managing Racket modules and namespaces.
;
; This library isn't exactly a full Arc module system, but it may be
; useful or instructive to anyone who's inspired to make one. As far
; as I (rocketnia) can tell, the biggest hurdles remaining to making a
; good module system are as follows:
;
;   - Arc macros are a little bit too unhygienic. You can't just
;     import a macro and use it right away, 'cause you also have to
;     import all the variables the macro's expansions could refer to.
;
;   - An Arc module system may need to keep track of other things than
;     global variables, such as type symbols and global table entries.
;     For instance, if two Arc libraries both use types named
;     'special-fn with 'defcall behavior, you get type symbol conflict
;     table entry conflict (the entry for coerce*!fn!special-fn) at
;     the same time.
;
; Parts of these issues can be solved by having all Arc programmers
; follow certain conventions in their code. However, there's a good
; chance the Arc core itself needs to follow those conventions in
; order for the module system to feel seamless, and that may change
; the language to the point that it isn't *really* Arc (whatever that
; means).
;
; This introduces seven types: 'rns, 'anchor, 'ns, 'module, 'rmodule,
; 'modecule, and 'rns-var. The R stands for "Racket," the NS stands
; "namespace", and the MODECULE stands for justice and freedom. For
; each type that starts with R, the non-R version (if there is one)
; automatically converts between Arc variable names and Racket
; variable and Racket variable names so that it's easy to do a certain
; amount of acrobatics with modules and namespaces without
; acknowledging their Racket origins.
;
; Modecules are a bit of an experiment that doesn't seem so useful
; after the fact. Short for "module molecule," they're like modules
; but with one export, which can be imported under various names using
; '{r,}ns-set-modecule. It would be even more useful to have
; '{r,}ns-set-import utilities which take care of renaming using an
; optional "original name" argument. TODO: Implement that.
;
; This library also requires a slight change to ac.scm: Instead of Arc
; global variables being set using 'namespace-set-variable-value!,
; they're now set using 'set!, and the Racket version of an Arc
; command is compiled using 'compile-allow-set!-undefined. See
; 'arc-exec in ac.scm for more details about how this helps.

(require "lib/extend.arc")

(extend type (x) $.namespace?.x
  'rns)

(extend type (x) $.namespace-anchor?.x
  'anchor)

(def ns-racketarc (x)
  (annotate 'ns (list rnsify.x)))

(def ns-arcracket (x)
  (!0:rep nsify.x))

(def global-racketarc (global)
  " Converts a Racket top-level variable name (a symbol) into the name
    the variable is visible as from Arc. "
  (unless $.symbol-interned?.global
    (err "Can't global-racketarc a gensym."))
  (let name string.global
    (unless (begins name "_")
      (err:+ "Can't global-racketarc " (tostring write.global) "."))
    (sym:cut name 1)))

(def global-arcracket (global)
  " Converts an Arc global variable name (a symbol) into the
    corresponding Racket top-level variable name. "
  (unless $.symbol-interned?.global
    (err "Can't global-arcracket a gensym."))
  ac-global-name.global)

(def could-global-racketarc (global)
  (and (isa global 'sym)
       $.symbol-interned?.global
       (begins string.global "_")))

(def safely-global-racketarc (global)
  (when could-global-racketarc.global
    (list global-racketarc.global)))

(def safely-map-global-racketarc (globals)
  (mappend safely-global-racketarc globals))

(def rnsify (x)
  (err:+ "Can't rnsify " (tostring write.x)))

(extend rnsify (x) (isa x 'rns)
  x)

(def nsify (x)
  (err:+ "Can't nsify " (tostring write.x)))

(extend nsify (x) (isa x 'ns)
  x)

(defvar current-rns
  ($.make-derived-parameter $.current-namespace rnsify idfn))

(def call-w/current-rns (rns body)
  (parameterize defvar-impl.current-rns rns
    (body)))

(mac w/current-rns (rns . body)
  `(call-w/current-rns ,rns (fn () ,@body)))

(defvar current-ns ($.make-derived-parameter defvar-impl.current-rns
                     ns-arcracket ns-racketarc))

(def call-w/current-ns (ns body)
  (parameterize defvar-impl.current-ns ns
    (body)))

(mac w/current-ns (ns . body)
  `(call-w/current-ns ,ns (fn () ,@body)))

(eval `($:define-namespace-anchor ,global-arcracket!main-ns-anchor*))

(def anchor-rns ((o anchor main-ns-anchor*))
  $.namespace-anchor->namespace.anchor)

(def anchor-empty-rns ((o anchor main-ns-anchor*))
  $.namespace-anchor->empty-namespace.anchor)

(extend rnsify (x) (isa x 'anchor)
  anchor-rns.x)

(def anchor-ns ((o anchor main-ns-anchor*))
  (ns-racketarc anchor-rns.anchor))

(def anchor-empty-ns ((o anchor main-ns-anchor*))
  (ns-racketarc anchor-empty-rns.anchor))

(extend nsify (x) (isa x 'anchor)
  (ns-racketarc rnsify.x))

(= anon-module-prefix* (string (uniq) '-module-))

(= racket/bare-bones--plain-module-begin (uniq))
(= racket/bare-bones--define (uniq))
(= racket/bare-bones--define-customvar (uniq))
(= racket/bare-bones--quote (uniq))
(= racket/bare-bones--datum (uniq))
(= racket/bare-bones--set (uniq))
(= racket/bare-bones--app (uniq))
(= racket/bare-bones--require (uniq))
(= racket/bare-bones--provide (uniq))

; We define racket/bare-bones, a stripped-down version of racket/base
; where every variable is named as a gensym, just to make sure it's
; possible for our module utilities to define modules which provide
; exports with names like 'define or '#%app which would clash with the
; things used to define those very modules.
;
(eval `($:module racket/bare-bones racket/base
         (require (for-syntax racket/base))
         (define-syntax-rule (define-customvar var getter setter)
           (define-syntax var
             (make-set!-transformer
               (lambda (stx)
                 (syntax-case stx (set!)
                   (id (identifier? #'id) #'(getter))
                   ((set! _ val) #'(setter val)))))))
         (provide (rename-out
                    (#%plain-module-begin
                      ,racket/bare-bones--plain-module-begin)
                    (define     ,racket/bare-bones--define)
                    (define-customvar
                      ,racket/bare-bones--define-customvar)
                    (quote      ,racket/bare-bones--quote)
                    (#%datum    ,racket/bare-bones--datum)
                    (set!       ,racket/bare-bones--set)
                    (#%app      ,racket/bare-bones--app)
                    (#%require  ,racket/bare-bones--require)
                    (#%provide  ,racket/bare-bones--provide)))))

; We manipulate a Racket module as a module path together with a
; Racket namespace the module is registered in.
(def pathed-rmodule (rns path)
  (annotate 'rmodule (list rnsify.rns path)))

(def rmodulify (x)
  (err:+ "Can't rmodulify " (tostring write.x) "."))

(extend rmodulify (x) (isa x 'rmodule)
  x)

(def modulify (x)
  (err:+ "Can't modulify " (tostring write.x) "."))

(extend modulify (x) (isa x 'module)
  x)

(def module-racketarc (rmodule)
  (annotate 'module (list rmodulify.rmodule)))

(def module-arcracket (module)
  (!0:rep modulify.module))

(def rmodule-keys (rmodule)
  (let (rns path)  (rep rmodulify.rmodule)
    (mappend (fn ((phase . exports)) (map car exports))
      ($.call-with-values
        (fn () (w/current-rns rns $.module->exports.path)) join))))

(def module-keys (module)
  (safely-map-global-racketarc:rmodule-keys:module-arcracket
    modulify.module))

(def instantiate-rmodule (rmodule)
  " Instantiates a Racket module by first delving into its internal
    Arc as a combination of a module path and an example namespace
    which has the module attached on that path, and then requiring
    that path in that namespace. "
  (let (rns path) (rep rmodulify.rmodule)
    (w/current-rns rns ($.dynamic-require path ($.void))))
  rmodule)

(def embed-racket/bare-bones (result)
  " Makes a `racket/bare-bones' expression out of the literal value
    `result' by embedding it inside a procedure call. This is
    necessary so that Racket doesn't translate it into immutable
    syntax and back. "
  ($.list racket/bare-bones--app
    (cons racket/bare-bones--datum (fn () result))))

(def make-bare-bones-rmodule (racket-module-body)
  " Makes a Racket module based on `racket/bare-bones' and the given
    Racket list of top-level module expressions. We create the module
    by evaluating a Racket `(module ...) form in the main namespace of
    Arc. The resulting module will have a gensym for a name (even if
    Racket's `current-module-declare-name' would have overridden
    that), and Racket's `compile-enforce-module-constants' parameter
    will be `#f' while the module is being compiled, so that its
    module-level variables can be redefined or assigned to later on. "
  (let name uniq.anon-module-prefix*
    (let expr ($.list 'module name (ac-denil ''racket/bare-bones)
                (cons racket/bare-bones--plain-module-begin
                  racket-module-body))
      (w/current-ns (anchor-ns)
        (let compiled (parameterize
                          $.compile-enforce-module-constants scheme-f
                        $.compile.expr)
          (parameterize $.current-module-declare-name scheme-f
            $.eval.compiled))))
    (pathed-rmodule (anchor-empty-rns) (ac-denil `',name))))

(def make-simple-rmodule binds
  (make-bare-bones-rmodule:ac-denil:mappend
    (fn ((var val))
      (let box $.box.val
        `((,racket/bare-bones--define-customvar ,var
            ,(embed-racket/bare-bones:fn () $.unbox.box)
            ,(embed-racket/bare-bones
               ; NOTE: We would use [] syntax, but that would try to
               ; ssexpand 'set-box!.
               (fn (val) (($ set-box!) box val))))
          (,racket/bare-bones--provide ,var))))
    pair.binds))

(def make-simple-module binds
  (module-racketarc:apply make-simple-rmodule
    (mappend [list (global-arcracket _.0) _.1] pair.binds)))

(mac simple-rmod binds
  `(make-simple-rmodule ,@(mappend [do `(',_.0 ,_.1)] pair.binds)))

(mac simple-mod binds
  `(make-simple-module ,@(mappend [do `(',_.0 ,_.1)] pair.binds)))

(def make-sub-rmodule (rmodule var-test)
  (let (rns path) (rep rmodulify.rmodule)
    (make-bare-bones-rmodule:ac-denil
      `((,racket/bare-bones--require ,path)
        ,@(map [do `(,racket/bare-bones--provide ,_)]
               (keep var-test rmodule-keys.rmodule))))))

(def make-renaming-rmodule (rmodule renamer)
  (let (rns path) (rep rmodulify.rmodule)
    (make-bare-bones-rmodule:ac-denil
      `((,racket/bare-bones--require ,path)
        ,@(map [do `(,racket/bare-bones--provide
                      (rename ,_ ,renamer._))]
               rmodule-keys.rmodule)))))

(extend rnsify (x) (isa x 'rmodule)
  (let (rns path) (rep instantiate-rmodule.x)
    (w/current-rns rns $.module->namespace.path)))

(extend nsify (x) (isa x 'module)
  (ns-racketarc:rnsify module-arcracket.x))

(def expand-w/rmodule (rmodule body)
  (zap instantiate-rmodule rmodule)
  (let (rns path) rep.rmodule
    ; We introduce local variables corresponding to the module's
    ; exports so that the Arc compiler doesn't use 'ac-global-name for
    ; those variables within 'body.
    `(with ,(mappend [do `(,_ nil)] rmodule-keys.rmodule)
       ($:local-require ,path)
       ,@body)))

(def expand-w/module (module body)
  (zap module-arcracket:modulify module)
  (zap make-sub-rmodule module could-global-racketarc)
  (zap make-renaming-rmodule module global-racketarc)
  (expand-w/rmodule module body))

(mac w/rmodule (rmodule . body)
  " Evaluates `rmodule' at expansion time and uses Racket's
    `local-require' to require the resulting module in a local
    scope for `body'. "
  (expand-w/rmodule eval.rmodule body))

(mac w/module (module . body)
  " Evaluates `module' at expansion time and uses Racket's
    `local-require' to require the Arc variables of the resulting
    module in a local scope for `body'. "
  (expand-w/module eval.module body))

(= modecule-var* 'val)  ; This is an Arc variable name.

(def view-modecule (module var)
  (annotate 'modecule (list module var)))

(def make-modecule (val (o var modecule-var*))
  (view-modecule (make-simple-module var val) var))

(def rns-var (var (o default-rns current-rns))
  (case type.var
    sym      (annotate 'rns-var (list var rnsify.default-rns))
    rns-var  var
             (err:+ "Can't rns-var " (tostring write.var))))

(withs (racket-stx [let (var rns) (rep rns-var._)
                     (w/current-rns rns
                       $.namespace-symbol->identifier.var)]
        (top set app datum quote-stx define-syntax)
          (map racket-stx
            '(#%top set! #%app #%datum quote define-syntax))
        embed [$.list app (cons datum (fn () _))])

  (def rns-get (var (o rns current-rns))
    " Gets a variable from a Racket namespace by evaluating it in
      Racket. Actually, it's sent through Racket's 'expand-to-top-form
      so that we can use the core #%top form if necessary rather than
      relying on the namespace itself to have one. "
    (let (var rns) (rep:rns-var var rns)
      (w/current-rns rns
        (let expanded $.expand-to-top-form.var
          ; If the expanded form is an identifier and its binding is
          ; #f (signifying a top-level binding), we use the core #%top
          ; form. Otherwise, we just evaluate it as-is.
          ($.eval:if (and $.identifier?.expanded
                          (no $.identifier-binding.expanded))
            ($.cons top expanded)
            expanded)))))

  (def ns-get (var (o ns current-ns))
    " Gets a variable from a namespace by evaluating it in Racket.
      Actually, it's sent through Racket's 'expand-to-top-form so that
      we can use the core #%top form if necessary rather than relying
      on the namespace itself to have one. "
    (rns-get global-arcracket.var ns-arcracket.ns))

  (def rns-set (var val (o rns current-rns))
    " Sets a variable in a Racket namespace using Racket's 'set!. "
    (let (var rns) (rep:rns-var var rns)
      (w/current-rns rns ($.arc-exec:$.list set var embed.val)))
    val)

  (def ns-set (var val (o ns current-ns))
    " Sets a variable in a namespace using Racket's 'set!. "
    (rns-set global-arcracket.var val ns-arcracket.ns))

  (def rns-ownspace-set (var val (o rns current-rns))
    " Sets a top-level variable in a Racket namespace without changing
      the corresponding identifier mapping to point to that
      variable. "
    (let (var rns) (rep:rns-var var rns)
      (($ namespace-set-variable-value!) var val scheme-f rnsify.rns))
    val)

  (def ns-ownspace-set (var val (o ns current-ns))
    " Sets a top-level variable in a namespace without changing the
      corresponding identifier mapping to point to that variable. "
    (rns-ownspace-set global-arcracket.var val ns-arcracket.ns))

  (def rns-set-own (var val (o rns current-rns))
    " Sets a top-level variable in a Racket namespace and changes the
      corresponding identifier mapping to point to that variable. "
    (let (var rns) (rep:rns-var var rns)
      (($ namespace-set-variable-value!) var val scheme-t rnsify.rns))
    val)

  (def ns-set-own (var val (o ns current-ns))
    " Sets a top-level variable in a namespace and changes the
      corresponding identifier mapping to point to that variable. "
    (rns-set-own global-arcracket.var val ns-arcracket.ns))

  (def rns-set-renamer (observing-var
                        canonical-var (o canonical-rns current-rns))
    " Changes an identifier mapping in a Racket namespace to point to
      a rename transformer. "
    (let (observing-var observing-rns) (rep rns-var.observing-var)
      (ret transformer ($.make-rename-transformer:racket-stx:rns-var
                         canonical-var canonical-rns)
        (w/current-rns observing-rns
          ($.arc-exec:$.list
            define-syntax observing-var embed.transformer)))))

  (def ns-set-renamer (observing-var
                       canonical-var (o canonical-ns current-ns))
    " Changes an identifier mapping in a namespace to point to a
      rename transformer. "
    (rns-set-renamer global-arcracket.observing-var
      global-arcracket.canonical-var ns-arcracket.canonical-ns))

  (def rns-set-modecule (var modecule (o rns current-rns))
    (withs ((var rns) (rep:rns-var var rns)
            (mod modecule-var) rep.modecule
            (mod-rns path) (rep module-arcracket.mod))
      (w/current-rns rns
        ($.namespace-require:$.list 'rename
          path var global-arcracket.modecule-var)))
    modecule)

  (def ns-set-modecule (var modecule (o ns current-ns))
    (rns-set-modecule global-arcracket.var modecule ns-arcracket.ns))
  )

(defcall rns (self var)
  (rns-get var self))

(defcall ns (self var)
  (ns-get var self))

(extend sref (self val . args) (and (isa self 'rns) single.args)
  (rns-set car.args val self))

(extend sref (self val . args) (and (isa self 'ns) single.args)
  (ns-set car.args val self))

(defcall rmodule (self var)
  (rns-get var self))

(defcall module (self var)
  (ns-get var self))

(extend sref (self val . args) (and (isa self 'rmodule) single.args)
  (rns-set car.args val self))

(extend sref (self val . args) (and (isa self 'module) single.args)
  (ns-set car.args val self))

(def make-ns binds
  (ret result (anchor-empty-ns)
    (each (var val) pair.binds
      (ns-set-own var val result))))

(def make-base-ns binds
  (ret result ($.make-base-namespace)
    (each (var val) pair.binds
      (ns-set-own var val result))))

(mac nsobj binds
  `(make-ns ,@(mappend [do `(',_.0 ,_.1)] pair.binds)))

(def rns-keys (rns)
  (copylist:$.namespace-mapped-symbols rnsify.rns))

(def ns-keys (ns)
  (safely-map-global-racketarc:rns-keys ns-arcracket.ns))


codegen: changed to use 'ppr-sexp to print out code

;------------------------------------------------------------------------------

; code generation

(def code-generate (ast)
  (withs
    (lambda-todo '()
     lambda-count 0
     global-vars (fv ast)
     add-lambda [let i lambda-count (push (cons lambda-count _) lambda-todo) (++ lambda-count) i]
     ; private functions
     code-gen nil
     compile-all-lambdas nil)

  (= code-gen (fn (ast stack-env)
    (let (cg-list cg-args access-var cg) nil
      (= cg-list (fn (asts vars stack-env sep k)
        (if (no asts)
          (k "" stack-env)
          (let x (code-gen (car asts) stack-env)
            (cg-list (cdr asts) (cdr vars) (cons (car vars) stack-env) sep (fn (code stack-env) (k (list x sep code) stack-env)))))))

      (= cg-args (fn (args stack-env)
        (cg-list args (range 1 (len args)) stack-env "" (fn (code stack-env) code))))

      (= access-var (fn (var stack-env)
        (if (aglobal var)
          (let i (pos var global-vars)
            (list "GLOBAL(" i "/*" var!uid "*/)"))
          (let i (- (len stack-env) (pos var stack-env) 1)
            (list "LOCAL(" i "/*" var!uid "*/)")))))

      (= cg (fn (ast)
        (if
          (alit ast)
            (let val ast!val
              (if
                (no val) (list " PUSH(NILOBJ);")
                (is val t) (list " PUSH(TOBJ);")
                (list " PUSH(FIX2OBJ(" val "));")))
          (aquote ast)
            (list " PUSH(SYM2OBJ(\"" (car ast!subx) "\"));")
          (aref ast)
            (list " PUSH(" (access-var ast!var stack-env) ");")
          (aset ast)
            (list (cg (car ast!subx)) " " (access-var ast!var stack-env) " = TOS();")
          (acnd ast)
            (let x (map cg ast!subx)
              (list (car x) "\n if (POP() != NILOBJ) {\n" (cadr x) "\n } else {\n" (car:cddr x) "\n }"))
          (aprim ast)
            (let args ast!subx
              (if
                (is ast!op '%cons) (list (cg-args args stack-env) " CONS();")
                (is ast!op '%car) (list (cg-args args stack-env) " CAR();")
                (is ast!op '%cdr) (list (cg-args args stack-env) " CDR();")
                (is ast!op '%type) (list (cg-args args stack-env) " TYPE();")
                (is ast!op '%is) (list (cg-args args stack-env) " EQ();")
                (is ast!op '%isnt) (list (cg-args args stack-env) " NEQ();")
                (is ast!op '%<) (list (cg-args args stack-env) " LT();")
                (is ast!op '%>) (list (cg-args args stack-env) " GT();")
                (is ast!op '%<=) (list (cg-args args stack-env) " LE();")
                (is ast!op '%>=) (list (cg-args args stack-env) " GE();")
                (is ast!op '%+) (list (cg-args args stack-env) " ADD();")
                (is ast!op '%-) (list (cg-args args stack-env) " SUB();")
                (is ast!op '%*) (list (cg-args args stack-env) " MUL();")
                (is ast!op '%pr) (list (cg-args args stack-env) " PR();")
                (is ast!op '%prn) (list (cg-args args stack-env) " PRN();")
                (is ast!op '%halt) (list (cg-args args stack-env) " HALT();")
                (is ast!op '%closure)
                  (withs
                    (i (add-lambda (car args))
                     n (len (cdr args))
                     s (list "CLOSURE(" i "," n ");"))
                    (list (cg-args (cdr args) stack-env) " BEGIN_" s (map [list " INICLO(" _ ");"] (rev:range 1 n)) " END_" s))
                (is ast!op '%closure-ref)
                  (let i ((cadr args) 'val)
                    (list (cg (car args)) " TOS() = CLOSURE_REF(TOS()," i ");"))
                (err "unknown primitive" ast!op)))
          (anapp ast)
            (withs
              (fun (car ast!subx)
               args (cdr ast!subx)
               n (len args))
              (if (alam fun)
                (cg-list args fun!params stack-env "\n" (fn (code new-stack-env) (list code (code-gen (car fun!subx) new-stack-env))))
                (cg-list args (range 1 n) stack-env "\n" (fn (code new-stack-env)
                  (with
                    (start (len stack-env)
                     s (list "JUMP(" n ");"))
                    (list code " BEGIN_" s (map [list " PUSH(LOCAL(" (+ _ start) "));"] (range 0 (- n 1))) " END_" s))))))
          (alam ast) ; this case is impossible after CPS-conversion
            (list " PUSH(FIX2OBJ(" (add-lambda ast) "));")
          (aseq ast) ; this case is impossible after CPS-conversion
            (map [list (cg _) "DROP();"] ast!subx)
            (err "unknown ast" ast))))

      (cg ast))))

  (= compile-all-lambdas (fn ()
    (if (no lambda-todo)
      ""
      (withs
        (x (car lambda-todo)
         ast (cdr x))
        (pop lambda-todo)
          (list
            "case " (car x) ":\n\n"
            (code-gen (car ast!subx) (rev ast!params))
            "\n\n"
            (compile-all-lambdas))))))

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"  "#define MAX_STACK " 10000 "\n" code-prefix*)
      code
      code-suffix*))))

(= code-prefix* "

#define GC_DEBUG

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gc.h>

#define MAX_SYMS 1000000
#define T_PAIR 0
#define T_SYM  1

typedef long obj;

typedef struct {
  long type; /* T_PAIR */
  obj car;
  obj cdr;
} pair;

typedef struct {
  long type; /* T_SYM */
  char * value;
} symbol;

obj global[NB_GLOBALS];
obj stack[MAX_STACK];
obj * closure;
obj * sp;
symbol * syms[MAX_SYMS]; /* To be replaced by a hash table */
int nsyms;

#define AFIX(o) ((o) & 1)     /* the last bit is 0 : it's a fixnum */
#define APTR(o) (!((o) & 1))  /* It's not a fixnum : it's a ref to something else */
#define ASYM(o) (((obj*)(o))[0] == T_SYM)
#define APAIR(o) (((obj*)(o))[0] == T_PAIR)

#define FIX2OBJ(n) (((n) << 1) + 1)
#define OBJ2FIX(o) ((o) >> 1)

#define GLOBAL(i) global[i]
#define LOCAL(i) stack[i]
#define CLOSURE_REF(self,i) ((obj *)(self))[i]

#define TOS() sp[-1]
#define PUSH(x) *sp++ = x
#define POP() *--sp

#define EQ() { obj y = POP(); TOS() = TOS() == y ? TOBJ : NILOBJ; }
#define NEQ() { obj y = POP(); TOS() = TOS() != y ? TOBJ : NILOBJ; }

#define TYPE() { obj * p; obj y = TOS();\\
  if (AFIX(y))\\
    TOS() = SYM2OBJ(\"int\");\\
  else{\\
    p = (obj *) y;\\
    switch ((char) *p){\\
      case T_PAIR: TOS() = SYM2OBJ(\"cons\"); break;\\
      case T_SYM: TOS() = SYM2OBJ(\"sym\"); break;\\
    }\\
  }\\
}

#define LT() { obj y = POP(); TOS() = TOS() < y ? TOBJ : NILOBJ; }
#define GT() { obj y = POP(); TOS() = TOS() > y ? TOBJ : NILOBJ; }
#define LE() { obj y = POP(); TOS() = TOS() <= y ? TOBJ : NILOBJ; }
#define GE() { obj y = POP(); TOS() = TOS() >= y ? TOBJ : NILOBJ; }
#define ADD() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) + y); }
#define SUB() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) - y); }
#define MUL() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) * y); }

#define CONS() { pair * p = GC_MALLOC (sizeof(pair)); p->type = T_PAIR ; p->cdr = POP(); p->car = POP(); PUSH((obj)p); }
#define CAR() { pair * p = (pair *) POP(); PUSH((obj)(p->car)); }
#define CDR() { pair * p = (pair *) POP(); PUSH((obj)(p->cdr)); }

#define PRN() { PR(); printf (\"\\n\");}

void PR(){
  pair * p;
  symbol * s;
  obj y = TOS();

  if (AFIX(y))
    printf (\"%ld\", OBJ2FIX(y));
  else if (ASYM(y)){
    s = (symbol *) y;
    printf (\"%s\", s->value);
  }
  else if (APAIR(y)){
    p = (pair *) y;
    printf (\"( \");
    PUSH(p->car); PR(); POP();
    printf (\" . \");
    PUSH(p->cdr); PR(); POP();
    printf (\" )\");
  }
}

#define HALT() break

#define BEGIN_CLOSURE(label,nbfree) closure = GC_MALLOC(sizeof(obj) * nbfree + 1);
#define INICLO(i) closure[i] = POP();
#define END_CLOSURE(label,nbfree) closure[0] = label; PUSH((obj)closure);

#define BEGIN_JUMP(nbargs) sp = stack;
#define END_JUMP(nbargs) pc = ((obj *)LOCAL(0))[0]; goto jump;

obj SYM2OBJ (char * s){ /* Find a symbol, or save it if it's the first time */
  int i;

  for (i = 0 ; i < nsyms ; i++)
    if (strcmp (s, syms[i]->value) == 0) /* found it */
      return (obj) syms[i];

  if (nsyms == MAX_SYMS){ /* Bad luck, really... */
    fprintf (stderr, \"Sorry, we just ran out of symbols. Please come back later...\\n\");
    exit (1);
  }

  syms[nsyms]        = malloc (sizeof(symbol)); /* Symbols never go away, then can be malloc-ed */
  syms[nsyms]->type  = T_SYM;
  syms[nsyms]->value = (char *) malloc (strlen (s) + 1);
  strcpy (syms[nsyms]->value, s);

  return (obj) syms[nsyms++];
}

obj execute (int pc)
{
  sp         = stack;
  obj NILOBJ = SYM2OBJ (\"nil\");
  obj TOBJ   = SYM2OBJ (\"t\");

  jump: switch (pc) {

")

(= code-suffix* "  }
  return POP();
}

int main (int argc, char * argv[]) {
  GC_INIT();
  execute(0);
  return 0;
}
")

;------------------------------------------------------------------------------

; debugging

(def source (ast)
  (if
    (alit ast)
       ast!val
    (aref ast)
      ((ast 'var) 'uid)
    (aset ast)
      (list 'set ((ast 'var) 'uid) (source (car ast!subx)))
    (acnd ast)
      (cons 'if (map source ast!subx))
    (aprim ast)
      (cons ast!op (map source ast!subx))
    (anapp ast)
      (if (alam (car ast!subx))
        (list 'let (map (fn (p a) (list p!uid (source a))) ((car ast!subx) 'params) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      (list 'fn (map [_ 'uid] ast!params) (source (car ast!subx)))
    (aseq ast)
      (cons 'do (map source ast!subx))
    (aquote ast)
      (cons 'quote ast!subx)
      ; if unknown AST, then probably still in list form
      ; (cref driver)
      ast))

(def ds (ast)
   (if
      (alit ast)
          (cons 'lit ast!val)
      (aref ast)
         (cons 'ref ((ast 'var) 'uid))
      (aset ast)
         (cons 'set (list 'set ((ast 'var) 'uid) (ds (car ast!subx))))
      (acnd ast)
         (cons 'cnd (cons 'if (map ds ast!subx)))
      (aprim ast)
         (cons 'prim (cons ast!op (map ds ast!subx)))
      (anapp ast)
      (cons 'app
         (if (alam (car ast!subx))
            (list 'let (map (fn (p a) (list p!uid (ds a))) ((car ast!subx) 'params) (cdr ast!subx)) (ds (car ((car ast!subx) 'subx))))
            (map ds ast!subx)))
      (alam ast)
         (cons 'lam (list 'fn (map [_ 'uid] ast!params) (ds (car ast!subx))))
      (aseq ast)
         (cons 'seq (cons 'do (map ds ast!subx)))
         ast))

; abstract away avoiding ' and the quoted parts of `
; body *must* return the value in 'var if it won't
; change anything
(mac code-walk (var code . body)
  (w/uniq usercode
    `(let ,usercode (fn (,var) ,@body)
       (*code-walk-internal ,usercode ,code))))

(def *code-walk-internal (usercode code)
  (let pass-to-user
       (fn (c)
         (let new-code (usercode c)
           (if (isnt new-code c)
               ; if change, rewalk the new code
               ; (don't move on unless code is stable)
               (*code-walk-internal usercode new-code)
               (if (acons new-code)
                   (map [*code-walk-internal usercode _] new-code)
                   new-code))))
    (if (acons code)
        (if
          (is (car code) 'quote)
            code
          (is (car code) 'quasiquote)
            (list 'quasiquote
               ((rfn quasiwalk (code)
                   (if (acons code)
                       (if
                         (is (car code) 'unquote)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         (is (car code) 'unquote-splicing)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         ; else
                           (map quasiwalk code))
                       code))
                 (cadr code)))
          ; else
            (pass-to-user code))
        (pass-to-user code))))

(def to-3-if (l)
  (code-walk code l
    (if
      (and (caris code 'if) (len> code 4))
        (let (_ c v . rest) code
          `(if ,c ,v (if ,@rest)))
      ; else
        code)))

; When self-compiling, probably need to define
; ssyntax and ssexpand lib functions
(def symbol-syntax (l)
  (code-walk code l
    (if
      (and (acons code) (ssyntax:car code))
        (let (fun . args) code
          (zap ssexpand fun)
          (if (caris fun 'compose)
              ((afn ((fun . rest))
                 (if rest
                     `(,fun ,(self rest))
                     `(,fun ,@args)))
               (cdr fun))
              `(,fun ,@args)))
      (ssyntax code)
        (ssexpand code)
      code)))

; handles (toplevel) 'load and 'require
; inefficiency note: allocs a lot of cons cells
(def include-files (l)
  (mappend
    (fn (e)
      ; if it's a 'load or 'require, include it
      (if (and (acons e) (in (car e) 'load 'require))
          (let (_ file . oops) e
            (when oops
              (err:string "Too many parameters to: " (car e)))
            ; make sure to recursively handle including files
            (include-files
              (w/infile s file
                (readall s (list 'detect-eof)))))
          (list e)))
    l))

;------------------------------------------------------------------------------

(def strip-ext (filename)
  (cut filename 0 (pos #\. filename)))

(def compile-file (filename (o debugmode t))
  (with (d (w/infile s filename (cons 'do (readall s (list 'detect-eof))))
         chain
         `(
            ; --------List form
            (,include-files "FILE INCLUSION")
            ; NOTE: all the 'code-walk passes might be
            ; better off in a single pass (just use a large
            ; 'if block).  Especially with regards to macros
            ; and symbol syntax: a ssyntax might emit a macro,
            ; which might emit a ssyntax, which might emit
            ; a macro... 'code-walk can actually handle this
            ; but only if macros and ssyntax expansion are
            ; in the same 'code-walk block
            (,symbol-syntax "ssyntax TRANSFORMATION")
            (,to-3-if "3-arg-if TRANSFORMATION")
            ; --------AST form
            (,[xe _ ()] "AST TRANSFORMATION")
            (,cps-convert "CPS-CONVERSION")
            (,closure-convert "CLOSURE-CONVERSION")))
    (= xe-global-cte* (make-initial-cte))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d (f old-d)
                  (when debugmode
                    (prn "------------------------------ " desc)
                    (ppr-sexp (source new-d)))
                  new-d))
              chain d))
    (w/outfile f (+ (strip-ext filename) ".c")
      (w/stdout f
        (prn:liststr:code-generate d)))))

;------------------------------------------------------------------------------

; code generation

(def code-generate (ast)
  (withs
    (lambda-todo '()
     lambda-count 0
     global-vars (fv ast)
     add-lambda [let i lambda-count (push (cons lambda-count _) lambda-todo) (++ lambda-count) i]
     ; private functions
     code-gen nil
     compile-all-lambdas nil)

  (= code-gen (fn (ast stack-env)
    (let (cg-list cg-args access-var cg) nil
      (= cg-list (fn (asts vars stack-env sep k)
        (if (no asts)
          (k "" stack-env)
          (let x (code-gen (car asts) stack-env)
            (cg-list (cdr asts) (cdr vars) (cons (car vars) stack-env) sep (fn (code stack-env) (k (list x sep code) stack-env)))))))

      (= cg-args (fn (args stack-env)
        (cg-list args (range 1 (len args)) stack-env "" (fn (code stack-env) code))))

      (= access-var (fn (var stack-env)
        (if (aglobal var)
          (let i (pos var global-vars)
            (list "GLOBAL(" i "/*" var!uid "*/)"))
          (let i (- (len stack-env) (pos var stack-env) 1)
            (list "LOCAL(" i "/*" var!uid "*/)")))))

      (= cg (fn (ast)
        (if
          (alit ast)
            (let val ast!val
              (if
                (no val) (list " PUSH(NILOBJ);")
                (is val t) (list " PUSH(TOBJ);")
                (list " PUSH(FIX2OBJ(" val "));")))
          (aquote ast)
            (list " PUSH(SYM2OBJ(\"" (car ast!subx) "\"));")
          (aref ast)
            (list " PUSH(" (access-var ast!var stack-env) ");")
          (aset ast)
            (list (cg (car ast!subx)) " " (access-var ast!var stack-env) " = TOS();")
          (acnd ast)
            (let x (map cg ast!subx)
              (list (car x) "\n if (POP() != NILOBJ) {\n" (cadr x) "\n } else {\n" (car:cddr x) "\n }"))
          (aprim ast)
            (let args ast!subx
              (if
                (is ast!op '%cons) (list (cg-args args stack-env) " CONS();")
                (is ast!op '%car) (list (cg-args args stack-env) " CAR();")
                (is ast!op '%cdr) (list (cg-args args stack-env) " CDR();")
                (is ast!op '%type) (list (cg-args args stack-env) " TYPE();")
                (is ast!op '%is) (list (cg-args args stack-env) " EQ();")
                (is ast!op '%isnt) (list (cg-args args stack-env) " NEQ();")
                (is ast!op '%<) (list (cg-args args stack-env) " LT();")
                (is ast!op '%>) (list (cg-args args stack-env) " GT();")
                (is ast!op '%<=) (list (cg-args args stack-env) " LE();")
                (is ast!op '%>=) (list (cg-args args stack-env) " GE();")
                (is ast!op '%+) (list (cg-args args stack-env) " ADD();")
                (is ast!op '%-) (list (cg-args args stack-env) " SUB();")
                (is ast!op '%*) (list (cg-args args stack-env) " MUL();")
                (is ast!op '%pr) (list (cg-args args stack-env) " PR();")
                (is ast!op '%prn) (list (cg-args args stack-env) " PRN();")
                (is ast!op '%halt) (list (cg-args args stack-env) " HALT();")
                (is ast!op '%closure)
                  (withs
                    (i (add-lambda (car args))
                     n (len (cdr args))
                     s (list "CLOSURE(" i "," n ");"))
                    (list (cg-args (cdr args) stack-env) " BEGIN_" s (map [list " INICLO(" _ ");"] (rev:range 1 n)) " END_" s))
                (is ast!op '%closure-ref)
                  (let i ((cadr args) 'val)
                    (list (cg (car args)) " TOS() = CLOSURE_REF(TOS()," i ");"))
                (err "unknown primitive" ast!op)))
          (anapp ast)
            (withs
              (fun (car ast!subx)
               args (cdr ast!subx)
               n (len args))
              (if (alam fun)
                (cg-list args fun!params stack-env "\n" (fn (code new-stack-env) (list code (code-gen (car fun!subx) new-stack-env))))
                (cg-list args (range 1 n) stack-env "\n" (fn (code new-stack-env)
                  (with
                    (start (len stack-env)
                     s (list "JUMP(" n ");"))
                    (list code " BEGIN_" s (map [list " PUSH(LOCAL(" (+ _ start) "));"] (range 0 (- n 1))) " END_" s))))))
          (alam ast) ; this case is impossible after CPS-conversion
            (list " PUSH(FIX2OBJ(" (add-lambda ast) "));")
          (aseq ast) ; this case is impossible after CPS-conversion
            (map [list (cg _) "DROP();"] ast!subx)
            (err "unknown ast" ast))))

      (cg ast))))

  (= compile-all-lambdas (fn ()
    (if (no lambda-todo)
      ""
      (withs
        (x (car lambda-todo)
         ast (cdr x))
        (pop lambda-todo)
          (list
            "case " (car x) ":\n\n"
            (code-gen (car ast!subx) (rev ast!params))
            "\n\n"
            (compile-all-lambdas))))))

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"  "#define MAX_STACK " 10000 "\n" code-prefix*)
      code
      code-suffix*))))

(= code-prefix* "

#define GC_DEBUG

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gc.h>

#define MAX_SYMS 1000000
#define T_PAIR 0
#define T_SYM  1

typedef long obj;

typedef struct {
  long type; /* T_PAIR */
  obj car;
  obj cdr;
} pair;

typedef struct {
  long type; /* T_SYM */
  char * value;
} symbol;

obj global[NB_GLOBALS];
obj stack[MAX_STACK];
obj * closure;
obj * sp;
symbol * syms[MAX_SYMS]; /* To be replaced by a hash table */
int nsyms;

#define AFIX(o) ((o) & 1)     /* the last bit is 0 : it's a fixnum */
#define APTR(o) (!((o) & 1))  /* It's not a fixnum : it's a ref to something else */
#define ASYM(o) (((obj*)(o))[0] == T_SYM)
#define APAIR(o) (((obj*)(o))[0] == T_PAIR)

#define FIX2OBJ(n) (((n) << 1) + 1)
#define OBJ2FIX(o) ((o) >> 1)

#define GLOBAL(i) global[i]
#define LOCAL(i) stack[i]
#define CLOSURE_REF(self,i) ((obj *)(self))[i]

#define TOS() sp[-1]
#define PUSH(x) *sp++ = x
#define POP() *--sp

#define EQ() { obj y = POP(); TOS() = TOS() == y ? TOBJ : NILOBJ; }
#define NEQ() { obj y = POP(); TOS() = TOS() != y ? TOBJ : NILOBJ; }

#define TYPE() { obj * p; obj y = TOS();\\
  if (AFIX(y))\\
    TOS() = SYM2OBJ(\"int\");\\
  else{\\
    p = (obj *) y;\\
    switch ((char) *p){\\
      case T_PAIR: TOS() = SYM2OBJ(\"cons\"); break;\\
      case T_SYM: TOS() = SYM2OBJ(\"sym\"); break;\\
    }\\
  }\\
}

#define LT() { obj y = POP(); TOS() = TOS() < y ? TOBJ : NILOBJ; }
#define GT() { obj y = POP(); TOS() = TOS() > y ? TOBJ : NILOBJ; }
#define LE() { obj y = POP(); TOS() = TOS() <= y ? TOBJ : NILOBJ; }
#define GE() { obj y = POP(); TOS() = TOS() >= y ? TOBJ : NILOBJ; }
#define ADD() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) + y); }
#define SUB() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) - y); }
#define MUL() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) * y); }

#define CONS() { pair * p = GC_MALLOC (sizeof(pair)); p->type = T_PAIR ; p->cdr = POP(); p->car = POP(); PUSH((obj)p); }
#define CAR() { pair * p = (pair *) POP(); PUSH((obj)(p->car)); }
#define CDR() { pair * p = (pair *) POP(); PUSH((obj)(p->cdr)); }

#define PRN() { PR(); printf (\"\\n\");}

void PR(){
  pair * p;
  symbol * s;
  obj y = TOS();

  if (AFIX(y))
    printf (\"%ld\", OBJ2FIX(y));
  else if (ASYM(y)){
    s = (symbol *) y;
    printf (\"%s\", s->value);
  }
  else if (APAIR(y)){
    p = (pair *) y;
    printf (\"( \");
    PUSH(p->car); PR(); POP();
    printf (\" . \");
    PUSH(p->cdr); PR(); POP();
    printf (\" )\");
  }
}

#define HALT() break

#define BEGIN_CLOSURE(label,nbfree) closure = GC_MALLOC(sizeof(obj) * nbfree + 1);
#define INICLO(i) closure[i] = POP();
#define END_CLOSURE(label,nbfree) closure[0] = label; PUSH((obj)closure);

#define BEGIN_JUMP(nbargs) sp = stack;
#define END_JUMP(nbargs) pc = ((obj *)LOCAL(0))[0]; goto jump;

obj SYM2OBJ (char * s){ /* Find a symbol, or save it if it's the first time */
  int i;

  for (i = 0 ; i < nsyms ; i++)
    if (strcmp (s, syms[i]->value) == 0) /* found it */
      return (obj) syms[i];

  if (nsyms == MAX_SYMS){ /* Bad luck, really... */
    fprintf (stderr, \"Sorry, we just ran out of symbols. Please come back later...\\n\");
    exit (1);
  }

  syms[nsyms]        = malloc (sizeof(symbol)); /* Symbols never go away, then can be malloc-ed */
  syms[nsyms]->type  = T_SYM;
  syms[nsyms]->value = (char *) malloc (strlen (s) + 1);
  strcpy (syms[nsyms]->value, s);

  return (obj) syms[nsyms++];
}

obj execute (int pc)
{
  sp         = stack;
  obj NILOBJ = SYM2OBJ (\"nil\");
  obj TOBJ   = SYM2OBJ (\"t\");

  jump: switch (pc) {

")

(= code-suffix* "  }
  return POP();
}

int main (int argc, char * argv[]) {
  GC_INIT();
  execute(0);
  return 0;
}
")

;------------------------------------------------------------------------------

; debugging

(def source (ast)
  (if
    (alit ast)
       ast!val
    (aref ast)
      ((ast 'var) 'uid)
    (aset ast)
      (list 'set ((ast 'var) 'uid) (source (car ast!subx)))
    (acnd ast)
      (cons 'if (map source ast!subx))
    (aprim ast)
      (cons ast!op (map source ast!subx))
    (anapp ast)
      (if (alam (car ast!subx))
        (list 'let (map (fn (p a) (list p!uid (source a))) ((car ast!subx) 'params) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      (list 'fn (map [_ 'uid] ast!params) (source (car ast!subx)))
    (aseq ast)
      (cons 'do (map source ast!subx))
    (aquote ast)
      (cons 'quote ast!subx)
      ; if unknown AST, then probably still in list form
      ; (cref driver)
      ast))

(def ds (ast)
   (if
      (alit ast)
          (cons 'lit ast!val)
      (aref ast)
         (cons 'ref ((ast 'var) 'uid))
      (aset ast)
         (cons 'set (list 'set ((ast 'var) 'uid) (ds (car ast!subx))))
      (acnd ast)
         (cons 'cnd (cons 'if (map ds ast!subx)))
      (aprim ast)
         (cons 'prim (cons ast!op (map ds ast!subx)))
      (anapp ast)
      (cons 'app
         (if (alam (car ast!subx))
            (list 'let (map (fn (p a) (list p!uid (ds a))) ((car ast!subx) 'params) (cdr ast!subx)) (ds (car ((car ast!subx) 'subx))))
            (map ds ast!subx)))
      (alam ast)
         (cons 'lam (list 'fn (map [_ 'uid] ast!params) (ds (car ast!subx))))
      (aseq ast)
         (cons 'seq (cons 'do (map ds ast!subx)))
         ast))

; abstract away avoiding ' and the quoted parts of `
; body *must* return the value in 'var if it won't
; change anything
(mac code-walk (var code . body)
  (w/uniq usercode
    `(let ,usercode (fn (,var) ,@body)
       (*code-walk-internal ,usercode ,code))))

(def *code-walk-internal (usercode code)
  (let pass-to-user
       (fn (c)
         (let new-code (usercode c)
           (if (isnt new-code c)
               ; if change, rewalk the new code
               ; (don't move on unless code is stable)
               (*code-walk-internal usercode new-code)
               (if (acons new-code)
                   (map [*code-walk-internal usercode _] new-code)
                   new-code))))
    (if (acons code)
        (if
          (is (car code) 'quote)
            code
          (is (car code) 'quasiquote)
            (list 'quasiquote
               ((rfn quasiwalk (code)
                   (if (acons code)
                       (if
                         (is (car code) 'unquote)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         (is (car code) 'unquote-splicing)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         ; else
                           (map quasiwalk code))
                       code))
                 (cadr code)))
          ; else
            (pass-to-user code))
        (pass-to-user code))))

(def to-3-if (l)
  (code-walk code l
    (if
      (and (caris code 'if) (len> code 4))
        (let (_ c v . rest) code
          `(if ,c ,v (if ,@rest)))
      ; else
        code)))

; When self-compiling, probably need to define
; ssyntax and ssexpand lib functions
(def symbol-syntax (l)
  (code-walk code l
    (if
      (and (acons code) (ssyntax:car code))
        (let (fun . args) code
          (zap ssexpand fun)
          (if (caris fun 'compose)
              ((afn ((fun . rest))
                 (if rest
                     `(,fun ,(self rest))
                     `(,fun ,@args)))
               (cdr fun))
              `(,fun ,@args)))
      (ssyntax code)
        (ssexpand code)
      code)))

; handles (toplevel) 'load and 'require
; inefficiency note: allocs a lot of cons cells
(def include-files (l)
  (mappend
    (fn (e)
      ; if it's a 'load or 'require, include it
      (if (and (acons e) (in (car e) 'load 'require))
          (let (_ file . oops) e
            (when oops
              (err:string "Too many parameters to: " (car e)))
            ; make sure to recursively handle including files
            (include-files
              (w/infile s file
                (readall s (list 'detect-eof)))))
          (list e)))
    l))

;------------------------------------------------------------------------------

(def strip-ext (filename)
  (cut filename 0 (pos #\. filename)))

(def compile-file (filename (o debugmode t))
  (with (d (w/infile s filename (cons 'do (readall s (list 'detect-eof))))
         chain
         `(
            ; --------List form
            (,include-files "FILE INCLUSION")
            ; NOTE: all the 'code-walk passes might be
            ; better off in a single pass (just use a large
            ; 'if block).  Especially with regards to macros
            ; and symbol syntax: a ssyntax might emit a macro,
            ; which might emit a ssyntax, which might emit
            ; a macro... 'code-walk can actually handle this
            ; but only if macros and ssyntax expansion are
            ; in the same 'code-walk block
            (,symbol-syntax "ssyntax TRANSFORMATION")
            (,to-3-if "3-arg-if TRANSFORMATION")
            ; --------AST form
            (,[xe _ ()] "AST TRANSFORMATION")
            (,cps-convert "CPS-CONVERSION")
            (,closure-convert "CLOSURE-CONVERSION")))
    (= xe-global-cte* (make-initial-cte))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d (f old-d)
                  (when debugmode
                    (prn "------------------------------ " desc)
                    (prn (source new-d)))
                  new-d))
              chain d))
    (w/outfile f (+ (strip-ext filename) ".c")
      (w/stdout f
        (prn:liststr:code-generate d)))))