;;; @Package     Morc
;;; @Subtitle    Mock Arc Programming Language as Scheme Extension
;;; @HomePage    http://www.neilvandyke.org/morc/
;;; @AuthorEmail neil@@neilvandyke.org
;;; @Version     0.1
;;; @Date        2008-08-31

;; $Id: lang.ss,v 1.92 2008-08-31 10:12:37 neil Exp $

;;; @legal
;;; Copyright @copyright{} 2008 Neil Van Dyke.  This program is Free Software;
;;; you can redistribute it and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.  This
;;; program is distributed in the hope that it will be useful, but without any
;;; warranty; without even the implied warranty of merchantability or fitness
;;; for a particular purpose.  See
;;; @indicateurl{http://www.gnu.org/copyleft/lesser.html} for details.  For
;;; other licenses and consulting, contact the author.
;;; @end legal

;;; @section Introduction

;;; @i{Note: This is an incomplete implementation that I do not plan to pursue
;;; further.  It is being released only for purposes of publicly archiving the
;;; work thus far, in case someone in the future might benefit from it.  The
;;; current state of this is the result of two weekends of work, and then it
;;; was set aside due to other demands on my time.  This work was done with PLT
;;; 360, and looks like minor tweaks would be required to get it to work with
;;; PLT 4.  As I recall, I was last working on a namespace issue with PLT
;;; @code{defmacro}.}

;;; At the end of 2008-01, Paul Graham and Robert Morris made the initial
;;; release of the
;;; @uref{http://en.wikipedia.org/wiki/Arc_(programming_language), Arc
;;; programming language}.  There was no reference documentation, and as I read
;;; through the tutorial text file, I noticed a striking resemblance of Arc to
;;; Scheme -- Scheme, with lots of syntactic sugar, some Common Lisp-isms, some
;;; clever conveniences and shorthands that were inconsistent with Scheme.  I
;;; strongly suspected that Scheme was used as a starting point for Arc.  The
;;; similarities of Arc to Scheme inspired me to implement Arc as a set of
;;; Scheme macros and using a few extra features of PLT Scheme.  It was in the
;;; course of implementing much of Arc that I noticed the siginificant
;;; differences.  I decided to call my implementation Morc, as in ``mock Arc,''
;;; as in an imitation Arc.

;;; The Morc implementation is cleanroom, based only on the Arc tutorial, what
;;; little tidbits I'd noticed in public information, and my own knowledge of
;;; various programming languages and theory.

;;; Because Morc worked by expanding Arc code to PLT Scheme code, the PLT
;;; compilers could be used, which, incidentally, I suspected would make Morc
;;; much faster than the Arc reference implementation.  That is not a criticism
;;; of Arc, as the authors stated at the time that the implementation was to be
;;; more of an executable informal specification than efficient.

;;; I was planning on having the API reference for Morc double as a commentary
;;; on how Arc concepts relate to those in Scheme and other languages.  Two
;;; perceptions I noted at the time were ``Arc seems to value terseness,
;;; whereas Scheme values purity,'' and the even more inciting ``You can do Arc
;;; in [PLT] Scheme, but not Scheme in Arc.''

;;; File @code{test-morc.arc} is the beginning of a test suite for Arc, derived
;;; from the original Arc tutorial.

;;; Here are some instructions I wrote while developing this under PLT 360,
;;; which might or might not be correct.  ``To use, install the Morc
;;; @code{.plt} file.  (If you don't know how to install a @code{.plt} file,
;;; see @uref{http://download.plt-scheme.org/doc/dotplt.html}.)  Start
;;; DrScheme.  Select @b{Choose Language...} from the @b{File} menu, and choose
;;; @b{Morc}.  Morc can also be invoked as @code{mred -Z -z -M morc}, such as
;;; from within @uref{http://www.neilvandyke.org/quack/, Quack}.

;;; Please note that I've not touched any of the documentation, other than to
;;; add this Introduction for the release.  ``!!!'' is my notation meaning that
;;; the documentation there needs work before release (since three exclamation
;;; marks together should never occur under any circumstance), and is usually
;;; followed by cryptic notes.  Some of those notes allude to points I was
;;; intending to make in the annotated Morc reference documentation.

;;; Good night, and good luck.

;; TODO: fix any syntax "let" guards

;; TODO: Make reader read mutable strings.  WAIT! Check that Arc strings are
;; actually mutable.  For example, does "rem" mutate?

;; TODO: Read "~foo" as "(~ foo)".

;; TODO: Read "a:b:c" as "(: a b c)"

;; (namespace-syntax-introduce stx) returns a syntax object like stx, except
;; that the current namespace's bindings are included in the syntax object's
;; context (see section 12.3). The additional context is overridden by any
;; existing top-level context in the syntax object, or by any existing or
;; future module context. See section 12.2 for more information about syntax
;; objects.

(module lang mzscheme

  ;; (require-for-syntax "morc-fn.ss")
  ;; (require "morc-fn.ss")

  (require-for-syntax (only (lib "etc.ss") opt-lambda))

  (require (only (lib "list.ss") sort))
  (require (only (lib "etc.ss") opt-lambda))
  (require (only (lib "defmacro.ss") define-macro))

  (define-syntax morc-syntax-error (syntax-rules () ((_) #f)))

;;; @section nil and Booleans

  ;; TODO: need to have a boolean expression thing that treats null list as #f?
  ;; or hack mzscheme to translate both '() and #f to nil as needed?

  ;; TODO: this seems to be the main difference between arc0 and r5rs scheme.
  ;; we never expose scheme #t and #f through arc.  we always use nil (rather
  ;; than null) in arc representations, except for in list representations,
  ;; when we use null.  work is involved in making conditionals and lists work
  ;; correctly.

  ;; TODO: Replace the Scheme reader so that #t and #f are not accepted, "()"
  ;; translates to nil except when it is the cdr of a pair.

  ;; "It sometimes causes confusion to use the same thing for falsity and
  ;; the empty list, but many years of Lisp programming have convinced
  ;; me it's a net win, because the empty list is set-theoretic false,
  ;; and many Lisp programs think in sets." -- tutorial

  ;; TODO: documentation example: in '90s of using symbols for people in
  ;; symbolic programming in minilanguage in an internal web app and mentioning
  ;; that i'm screwed if anyone ever gets the username "nil".  someone i
  ;; mentioned to then got the username nil and I believe has it to this day.

;;; !!! ``Some implementations provide variables @code{nil} and @code{t} whose
;;; values in the initial environment are @code{#f} and @code{#t}
;;; respectively.'' [R3RS sec. 6.1]

;;; @defvar t
;;;
;;; Mostly same as Scheme, except it's spelled @code{t} instead of @code{#t},
;;; and in Scheme it is not a variable.  (Scheme's choice has the advantage of
;;; not using a single-letter symbol, which conceivably might come in handy
;;; when single letter symbols are used to represent letters in symbolic
;;; programming.)

  (define t 't)

;;; @defvar nil
;;;
;;; In Arc, this is both false and the null list value, whereas Scheme has
;;; distinguished the two for a long time.  Morc secretly uses Scheme null list
;;; in its representation of pairs, but exposes the null list only as
;;; @code{nil} through Arc.  Scheme's @code{#f} is not a variable.

  (define nil 'nil)

  ;; TODO: If can change the Scheme printer to print null list as nil, and read
  ;; quoted "nil" as null list... then do that, and then we only have to
  ;; special-case boolean tests.

  ;; TODO: For speed optimization it might help to turn these into syntax
  ;; extensions.  Don't do that until we have metrics.

  (define (nilornull? x)
    (or (eqv? nil x) (null? x)))

  (define (nilornull-to-false x)
    (if (nilornull? x) #f x))

  (define (nil-to-null x)
    (if (eqv? nil x) '() x))

  (define (null-to-nil x)
    (if (null? x) nil x))

  (define (false-to-nil x)
    (or x nil))

  (define (to-arcbool x)
    (if x t nil))

  (define (scheme-to-arc x)
    (cond ((null? x) nil)
          (else      (case x
                       ((#f) nil)
                       ((#t) t)
                       (else x)))))

;;; @defproc no val
;;;
;;; Same as Scheme, except Arc boolean values are used instead of Scheme's.

  (define (no x)
    (if (nilornull? x) t nil))

;;; @section Reader and Quoting

;;; The Arc reader is the same as R5RS Scheme's.  Morc uses the MzScheme
;;; reader, but with some features disabled.

  ;; !!! see this for possibly making us more Arc-like "(current-readtable
  ;; [readtable-or-false]) gets or sets a readtable that adjust the parsing of
  ;; S-expression input, or #f for the default behavior. See section 11.2.8 for
  ;; more information.".  Maybe that will help us map null lists in quoted list
  ;; car positions to nil, if #%quote and #%quasiquote won't.
  ;; http://download.plt-scheme.org/doc/360/html/mzscheme/mzscheme-Z-H-11.html#node_sec_11.2.8

  ;; TODO: Maybe write special quasiquote and quote, to replace null lists
  ;; (except in cdr positions) with nil, as well as to force nil in cdr
  ;; positions to null-list.

  ;;   (define (read-syntax@ src port)
  ;;     ;; Note: This is stolen from "collects/swindle/tools.ss" unit "tool@"
  ;;     ;; procedue "get-reader".
  ;;     (let ([v (read-syntax src port)])
  ;;                          (if (eof-object? v)
  ;;                            v
  ;;                            (namespace-syntax-introduce v))))

  ;; These are currently set in morc.ss
  ;;
  ;; (read-accept-bar-quote #f)
  ;; (read-accept-box #f)
  ;; (read-accept-compiled #f)
  ;; (read-accept-dot #t) ;; Note: Needed to read non-list pair literals with 360.
  ;; (read-accept-graph #f)
  ;; (read-accept-quasiquote #t)
  ;; (read-accept-reader #f)
  ;; (read-accept-reader #f)
  ;; (read-case-sensitive #t)
  ;; (read-curly-brace-as-paren #f)
  ;; (read-decimal-as-inexact #t)
  ;; (read-square-bracket-as-paren #f)

;;; @defsyntax : +@{ proc @}
;;;
;;; !!! not-arc

  ;;   (define-syntax :
  ;;     (syntax-rules ()
  ;;       ((_ X1 X2)           (X1 X2))
  ;;       ((_ X1 X2 X3 XN ...) (X1 (: X2 X3 XN ...)))))

  ;;   input: a:b:c
  ;;
  ;;   reader converts to: (: a b c)
  ;;
  ;;   expansion depends on context:
  ;;
  ;;   outside of app context: (: a b c)
  ;;   expands to: (lambda args (a (b (apply c args))))
  ;;
  ;;   in app context: ((: a b c) x y)
  ;;   expands to: (a (b (c x y)))
  ;;
  ;;   in setter lvalue context, handled differently

;;; @section Types

;;; @defproc type x
;;;
;;; !!! scheme has predicate procedures.  you can ask "number?" or "integer?"
;;;
;;; !!! though not shown in arc example, we return nil if we don't know type.
;;;
;;; !!! why spell out "string" but not abbreviate "number" as "num"?

  (define (type x)
    (cond ((symbol?    x) 'sym)
          ((integer?   x) 'int)
          ((number?    x) 'num)
          ((pair?      x) 'cons)
          ((procedure? x) 'fn)
          ((string?    x) 'string)
          ((char?      x) 'char)
          (else           nil)))

;;; @defproc isa x typ
;;;
;;; !!! achtung.  arc tutorial defines num and int types, and says @code{isa}
;;; is
;;;
;;; @lisp
;;; (def isa (x y) (is (type x) y))
;;; @end lisp
;;;
;;; which means that:
;;;
;;; @lisp
;;; (isa 42 'int) @result{} t
;;; (isa 42 'num) @result{} nil
;;; @end lisp
;;;
;;; !!! scheme integers answer both to integer? and number?
;;;
;;; @lisp
;;; (integer? 42) @result{} #t
;;; (number?  42) @result{} #t
;;; @end lisp

  (define (isa x typ)
    (to-arcbool (eqv? (type x) typ)))

;;; @defproc coerce x typ ?@{ extra @}

  (define coerce
    (let ((barf (lambda (x ty) (error "cannot coerce:" x ty)))
          (r    (lambda (e)    (if (nilornull? e) 10 e))))
      (opt-lambda (x ty (e nil))
        (case ty
          ((char)   (cond
                     ((char?    x) x)
                     ((integer? x) (integer->char x))
                     (barf x ty)))
          ((cons)   (cond
                     ((pair?    x) x)
                     ((string?  x) (string->list x))
                     (barf x ty)))
          ((int)    (cond
                     ((integer? x) x)
                     ((char?    x) (char->integer x))
                     ((string?  x) (cond
                                    ((string->number x (r e)) => truncate)
                                    (else nil)))
                     (barf x ty)))
          ((num)    (cond
                     ((number?  x) x)
                     ((char?    x) (char->integer x))
                     ((string?  x) (false-to-nil (string->number x (r e))))))
          ((string) (cond
                     ((string?  x) x)
                     ((number?  x) (number->string x (r e)))
                     (else (string x))))
          (else     (barf x ty))))))

;;; @section Numbers

;;; @defproc  even number
;;; @defprocx odd  number
;;;
;;; Same as Scheme @code{even?} and @code{odd?}, respectively, except they
;;; return Arc boolean values.

  (define (even x) (to-arcbool (even? x)))
  (define (odd  x) (to-arcbool (odd?  x)))

;;; @defproc  <  num1 +@{ num @}
;;; @defprocx >  num1 +@{ num @}
;;; @defprocx <= num1 +@{ num @}
;;; @defprocx >= num1 +@{ num @}
;;;
;;; Same as in Scheme, except they return Arc boolean values.
;;;
;;; !!! While not required for Arc tutorial, Morc extends these to also work
;;; on strings.

  ;; (define (<=@ . args) (to-arcbool (apply <= args)))
  ;; (define (<@  . args) (to-arcbool (apply <  args)))
  ;; (define (>=@ . args) (to-arcbool (apply >= args)))
  ;; (define (>@  . args) (to-arcbool (apply >  args)))

  (define-values (<=@ <@ >=@ >@)
    (let-syntax
        ((d (syntax-rules ()
              ((_ N S)
               (lambda args
                 (to-arcbool
                  (let ((x (car args)))
                    (cond
                     ((number? x) (apply N args))
                     ((string? x) (apply S args))
                     ((symbol? x) (apply S (map symbol->string args)))
                     (else (error (quote N) "invalid type:" args))))))))))
      (values (d <= string<=?)
              (d <  string<?)
              (d >= string>=?)
              (d >  string>?))))

;;; @defproc  expt x y
;;; @defprocx sqrt x
;;;
;;; Same as in Scheme.

;;; @defproc  ++ var
;;; @defprocx -- var

  ;;   (define-syntax (++ stx)
  ;;     (syntax-case stx ()
  ;;       ((_ ID)
  ;;        ;; TODO: Make this assertion a function?
  ;;        (unless (identifier? (syntax ID))
  ;;          (raise-syntax-error #f "expected an identifier" stx (syntax ID)))
  ;;        (set! !!!!!!!!!!!!!!
  ;;              WE NEED THE LOCATION/SETTER STUFF HERE TOO
  ;;              NEED TO EFFICIENTLY GET AND SET, IN ONE TRAVERSAL?

;;; @section Strings

;;; @defproc string *@{ arg @}
;;;
;;; !!! we convert lists and pairs together

  (define (string@ . args)
    (let ((os (open-output-string)))
      (letrec ((doit (lambda (x)
                       (cond ((nilornull? x) #f)
                             ((pair?      x) (doit (car x)) (doit (cdr x)))
                             (else           (display x os))))))
        (doit args))
      (begin0 (get-output-string os)
        (close-output-port os))))

;;; @section Lists

;;; @defproc  cons car cdr
;;; @defprocx car  pair
;;; @defprocx cdr  pair
;;; @defprocx list *@{ arg @}
;;;
;;;
;;; Same as in Scheme, except that the Arc @code{nil} object is used instead of
;;; the Scheme @code{()} null list.

  (define (cons@ a b)
    ;; Note: We're forcing any Scheme null list that somehow got into the car
    ;; position to nil, just to be as consistent as possible.
    (cons (null-to-nil a) (nil-to-null b)))

  (define (car@ x)
    ;; Note: We only need this for when the user uses quoted literals to
    ;; introduce a Scheme null list, and we will be nice and translate it to
    ;; nil.
    (null-to-nil (car x)))

  (define (cdr@ x)
    (null-to-nil (cdr x)))

  (define (list@ . args)
    (if (null? args)
        nil
        (apply list args)))

;;; @defproc cadr pair
;;;
;;; !!! why have this when arc has car:cdr composition?  the old lisp ca*d*r
;;; procedures could be seen a kludge around the lack of syntactic sugar.
;;;
;;; @lisp
;;; (cadr x) @equiv{} (car:cdr x)
;;; @end lisp

  (define (cadr@ lst)
    (car@ (cdr@ lst)))

;;; @defproc  nthcdr n lst
;;; @defprocx firstn n lst

  (define (nthcdr n lst)
    (if (not (and (integer? n) (>= n 0)))
        (raise-type-error 'nthcdr "counting number" n)
        (let loop ((n   n)
                   (lst (nil-to-null lst)))
          (if (zero? n)
              (null-to-nil lst)
              (loop (- n 1) (cdr lst))))))

  (define (firstn n lst)
    (cond ((zero? n) nil)
          ((not (and (integer? n) (>= n 0)))
           (raise-type-error 'firstn "counting number" n))
          (else (let loop ((lst (nil-to-null lst))
                           (n   n))
                  (cons (car lst)
                        (if (= 1 n)
                            '()
                            (loop (cdr lst) (- n 1))))))))

;;; @defproc tuples lst ?@{ size @}
;;;
;;; !!! Scheme has none.  Morc's implementation is in theory twice as efficient
;;; as the one in the Arc0 tutorial, and is implemented using named-@code{let}
;;; and multiple-value returns.  (example of why powerful fundamentals
;;; important to good algorithms)
;;;
;;; !!! first need fundamentals, rather than composing out of fancy primitives
;;; that might specify the functional behavior but aren't very good
;;; algorithmically.  example is "tuples"

  (define tuples
    (opt-lambda (lst (size 2))
      (cond ((not (and (integer? size) (>= size 1)))
             (raise-type-error 'tuples "counting number" size))
            ((nilornull? lst) nil)
            (else
             (let ((lst lst))
               ;; Note: lst is always non-null.
               (let each-tuple ((lst lst))
                 (let-values
                     (((tup rest)
                       (let each-item ((lst lst)
                                       (i   size))
                         (if (zero? i)
                             (values '() lst)
                             (let-values (((tup rest)
                                           (each-item (cdr lst) (- i 1))))
                               (values (cons (car lst) tup)
                                       rest))))))
                   (cons tup (if (null? rest)
                                 '()
                                 (each-tuple rest))))))))))

;;; @defproc  push val list-var
;;; @defprocx pop  list-var

  ;; TODO: Is this actually correct?  It handles the tutorial.  Probably we
  ;; have to handle compositions of multiple cdr, or even other locations.  I'm
  ;; not going to bother with the cdr semantics of pop until I know what push
  ;; is supposed to do.  And what should be the effect of this:
  ;;
  ;; (push 'new (cdr (car (cdr lst))))
  ;;
  ;; Probably requires set-cdr rather than new consing.  Makes sense, I think.

  (define-syntax push
    ;; TODO: We could error-check LST to make sure it's an identifier.
    (syntax-rules ()
      ;; Note: We're doing the "x" thing here to return this intermediate list
      ;; because that's what the tutorial example suggests, even though it's
      ;; not intuitive.  That might be hard to do with "set!".  I suspect that
      ;; the value shown in the tutorial is not correct wrt their intentions.
      ((_ VAL (HEAD LST))
       (if (eqv? HEAD cdr@)
           ;; TODO: we probably need to be using set-cdr! here rather than
           ;; new consing on front.
           (let ((x (cons VAL (nil-to-null (cdr LST)))))
             (set! LST (cons (car LST) x))
             x)
           (error 'push "expected cdr, got:" HEAD)))
      ((_ VAL LST)
       (begin (set! LST (cons VAL (nil-to-null LST))) LST))))

  (define-syntax pop
    ;; TODO: We could error-check LST to make sure it's an identifier.
    (syntax-rules () ;; cdr
      ((_ LST) (begin0 (car LST) (set! LST (null-to-nil (cdr LST)))))))

;;; @section Association Lists

  ;; !!! in scheme, the value is in the cdr, not in the car of the cdr like arc
  ;; tutorial suggests.

;;; @defproc alref alist key
;;;
;;; !!! what about not-found value or not-found thunk?  in morc, we've
;;; currently defined it to yield nil if key not found.  in scheme, you'd use
;;; assq, assv, and assoc.
;;;

  (define (alref alist key)
    (cond ((assoc key alist) => (lambda (x) (car (cdr x))))
          (else nil)))

;;; @section Hash Tables

  ;; TODO: See how space-efficient PLT's hash table implementation is for lots
  ;; of hash tables with only a few items, if, as the "obj" syntax suggests,
  ;; Arc intends to use them as objects.  I suspect Arc0 is just using PLT's
  ;; hash tables, since the "#hash" print format shown in the tutorial is the
  ;; same as PLT's hash table print format.

  (print-hash-table #t)

;;; @defproc table

  (define (table)
    (make-hash-table 'equal))

;;; @defproc listtab lst

  (define (listtab lst)
    (let ((ht (table)))
      (for-each (lambda (x)
                  ;; TODO: Better error message for malformed lst.
                  (apply (lambda (key val) (hash-table-put! ht key val)) x))
                lst)
      ht))

;;; @defsyntax obj *@{ key val @}

  (define-syntax obj
    (syntax-rules ()
      ((_) (table))
      ((_ X ...) (obj:2 () X ...))))

  (define-syntax obj:2
    (syntax-rules ()
      ((_ X)                 (listtab (quasiquote X)))
      ((_ (X ...) K V R ...) (obj:2 (X ... (K (unquote V))) R ...))
      ((_ X K)               (morc-syntax-error
                              "obj: missing value for key:" K))))

;;;  @defproc  keys ht
;;;  @defprocx vals ht
;;;
;;; !!! plt-scheme has hash-table-map, which is better

  (define (keys ht)
    (hash-table-map ht (lambda (k v) k)))

  (define (vals ht)
    (hash-table-map ht (lambda (k v) v)))

;;; @defproc maptable proc ht
;;;
;;; !!! Why call it ``map'' if it doesn't function analogously to @code{map}?
;;; And why not return the result of mapping via @var{proc}?  ``There is a
;;; function called maptable for hash tables that is like map for lists, except
;;; that it returns the original table instead of a new one.''

  (define (maptable proc ht)
    (hash-table-for-each ht proc)
    ht)

;;; @section Equality and Identity

  ;; TODO: This semantics might not be quite right.

;;; @defproc is  obj1 obj2
;;; @defproc iso obj1 obj2
;;;
;;; !!!

  (define (is a b)
    (to-arcbool (if (string? a)
                    (equal? a b)
                    (eqv? a b))))

  (define (iso a b)
    (to-arcbool (equal? a b)))

;;; @defproc in key *@{ item @}
;;;
;;; !!!

  (define (in key . items)
    (to-arcbool (if (string? key)
                    (member key items)
                    (memv   key items))))

;;; @section Closures

;;; @defsyntax fn ( *@{ arg @} ) *@{ body @}
;;;
;;; Same as Scheme @code{lambda}, without the apparent ability [!!!] to collect
;;; the rest of a list of values into one argument.
;;;
;;; !!! optional args is like opt-lambda, just with extraneous "o"

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

  ;;   (define-syntax fn
  ;;     (syntax-rules ()
  ;;       ((_ ARGS)               (fn ARGS nil))
  ;;       ((_ (ARG ...) BODY ...) (fn:s () (ARG ...) BODY ...))
  ;;       ((_ ARGS      BODY ...) (lambda ARGS BODY ...))))

  ;;   (define-syntax fn:s
  ;;     (syntax-rules ()
  ;;       ((_    X         ()              B ...) (lambda X B ...))
  ;;       ((_    (X ...  ) ((A ...) R ...) B ...)
  ;;        (fn:o (X ...  ) ((A ...) R ...) B ...))
  ;;       ((_    (X ...  ) (A       R ...) B ...)
  ;;        (fn:s (X ... A) (        R ...) B ...))))

  ;;   (define-syntax fn:o
  ;;     (syntax-rules (o)
  ;;       ((_    X               ()                B ...) (opt-lambda X B ...))
  ;;       ((_    (X ...        ) ((o A)     R ...) B ...)
  ;;        (fn:o (X ... (A nil)) (          R ...) B ...))
  ;;       ((_    (X ...        ) ((o A ...) R ...) B ...)
  ;;        (fn:o (X ... (A ...)) (          R ...) B ...))
  ;;       ((_    (X ...        ) ((A ...)   R ...) B ...)
  ;;        (morc-syntax-error "invalid argument" (A ...)))
  ;;       ((_    (X ...        ) (A         R ...) B ...)
  ;;        (fn:o (X ... A      ) (          R ...) B ...))))

  ;;!!! handle rest-arg "." in "fn:s" and "fn:o"?

  ;; !!! This "kind-fn" or "kludge-fn" to let us share code between "fn" and
  ;; "mac" without hitting MzScheme phase-separation problems that presently
  ;; seem to me to require that we put the "fn" arg-processing code in a
  ;; separate module and file that is "require-for-syntax"'d as well as
  ;; "require"'d.

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

  (define-syntax fn
    (syntax-rules ()
      ((_ ARGS BODY ...) (ka f ARGS (BODY ...)))))

  ;; The "ka" ("kludge args") syntax is used to implement both "fn" and "mac"
  ;; (and, indirectly right now, "def").  Note that we couldn't have expanded
  ;; "mac" to "(define-macro NAME (fn ARGS BODY ...))" without putting the
  ;; definition of "fn" into a different module and file, due to MzScheme phase
  ;; separation.  Hence the way "ka:f" expands to the final expression.

  (define-syntax ka
    (syntax-rules ()
      ((_ K ARGS)           (ka      K ARGS      ( (quote nil))))
      ((_ K (ARG ...) BODY) (ka:s () K (ARG ...) BODY))
      ((_ K ARGS      BODY) (ka:f #f K ARGS      BODY))))

  (define-syntax ka:s
    (syntax-rules ()
      ((_    X         K ()              B) (ka:f #f K X B))
      ((_    (X ...  ) K ((A ...) R ...) B)
       (ka:o (X ...  ) K ((A ...) R ...) B))
      ((_    (X ...  ) K (A       R ...) B)
       (ka:s (X ... A) K (        R ...) B))))

  (define-syntax ka:o
    (syntax-rules (o)
      ((_    X               K ()                B) (ka:f #t K X B))
      ((_    (X ...        ) K ((o A)     R ...) B)
       (ka:o (X ... (A (quote nil))) K (          R ...) B))
      ((_    (X ...        ) K ((o A ...) R ...) B)
       (ka:o (X ... (A ...)) K (          R ...) B))
      ((_    (X ...        ) K ((A ...)   R ...) B)
       (morc-syntax-error "invalid argument" (A ...)))
      ((_    (X ...        ) K (A         R ...) B)
       (ka:o (X ... A      ) K (          R ...) B))))

  (define-syntax ka:f
    (syntax-rules (m f)
      ((_ #t f     A (B ...)) (opt-lambda A B ...))
      ((_ #f f     A (B ...)) (lambda     A B ...))
      ((_ #t (m N) A (B ...)) (define-macro N (opt-lambda A B ...)))
      ((_ #f (m N) A (B ...)) (define-macro N (lambda     A B ...)))
      ((_ U ...) (morc-syntax-error "internal error"))))

  ;; TODO: Be more consistent with the syntax names.

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

;;; @section Application

;;; !!! scheme list sexy syntax is either a special form or a procedure
;;; application.  arc permits...

  (define scheme-apply apply)

  (define-syntax (%app stx)
    (syntax-case stx ()
      ((_ HEAD ARG)
       (syntax/loc stx (apply@ HEAD (list ARG))))
      ((_ HEAD ARGS ...)
       ;; There's no special application that doesn't have exactly-one
       ;; argument, so might as well expand this to a normal Scheme
       ;; application.
       (syntax/loc stx (HEAD ARGS ...)))))

  ;; TODO: This is an optimization for the benefit of "%app", but let's not
  ;; optimize at the cost of redudant code right now.  Worry about optimization
  ;; later.
  ;;
  ;; (define (apply-2 head arg)
  ;;   (cond ((procedure?  head) (               head arg))
  ;;         ((string?     head) (string-ref     head arg))
  ;;         ((hash-table? head) (hash-table-get head arg))
  ;;         (else (raise-type-error #f
  ;;                                 "function, string, or hash table" head))))

  (define (apply@ head args)
    (if (procedure?  head)
        (apply head args)
        (apply (cond ((string?     head) string-ref)
                     ((hash-table? head) hash-table-get/nofail)
                     (else (raise-type-error
                            #f
                            "function, string, or hash table"
                            head)))
               (cons head (nil-to-null args)))))

  (define (hash-table-get/nofail ht key)
    ;; This procedure exists solely to prevent "apply@" from supplying a
    ;; "failure-thunk-or-value" argument to MzScheme "hash-table-get".
    (hash-table-get ht key))

;;; @defproc apply func args
;;;
;;; !!! does special dispatch.  unclear whether Arc requires this.

;;; @section Binding and Assignment

  (compile-allow-set!-undefined #t)

;;; @defsyntax def !!!

  (define-syntax def
    ;; TODO: We don't currently return a value from "def", because Arc semantics
    ;; for "def" are probably otherwise the same as for Scheme "define".
    (syntax-rules ()
      ((_ (X ...) R ...)      (morc-syntax-error "invalid name"))
      ((_ NAME ARGS BODY ...) (define NAME (fn ARGS BODY ...)))))

;;; @defsyntax let !!!
;;;
;;; !!! we'll make this a letrec ... (does that help self-recursive lambda?)

  (define-syntax let@
    (syntax-rules ()
      ((_ SYM VAL)          (let@ SYM VAL nil))
      ((_ SYM VAL BODY ...) (letrec ((SYM VAL)) BODY ...))))

;;; @defsyntax with !!!
;;;
;;; !!! we'll make this a letrec ..., but maybe it should be a let*

  (define-syntax with
    (syntax-rules ()
      ((_ ())               nil)
      ((_ () BODY ...)      (begin BODY ...))
      ((_ (X ...))          (with (X ...) nil))
      ((_ (X ...) BODY ...) (with:2 () (X ...) BODY ...))))

  (define-syntax with:2
    (syntax-rules ()
      ((_ (X ...) ()          B ...) (letrec (X ...) B ...))
      ((_ (X ...) (S V R ...) B ...) (with:2 (X ... (S V)) (R ...) B ...))))

;;; @defsyntax = !!!

  (define-syntax =@
    (syntax-rules (nil t)
      ((_ A B)          (=:3 A B))
      ((_ A B REST ...) (=:2 () A B REST ...))))

  (define-syntax =:2
    (syntax-rules ()
      ((_ (X ...))              (begin X ...))
      ((_ (X ...) A B REST ...) (=:2 (X ... (=:3 A B)) REST ...))))

  (define-syntax (=:3 stx)
    (syntax-case stx (nil t)
      ;; TODO: Figure out the correct way to set inferred-name for procedures.
      ;;
      ;; (let* ((rvalue (syntax (B ...)))
      ;;        (whole  #`(let ((|(=)| #,rvalue))
      ;;                    (=:3 A |(=)|))))
      ;;   (syntax-property rvalue 'inferred-name (quote A))
      ;;   whole)
      ((_ A (B ...))
       (syntax/loc stx (let ((|(=)| (B ...))) (=:3 A |(=)|) |(=)|)))
      ((_ (HEAD ARG) VAL)
       ;; Note: Doesn't seem to be much point to optimizing by detecting
       ;; literals here, since what's the point of setting to a literal.
       (syntax (=app3 HEAD ARG VAL)))
      ((_ (HEAD ARG ...) VAL)
       (raise-syntax-error
        '= "unrecognized lvalue" stx (syntax/loc stx (HEAD ARG ...))))
      ((_ nil B) (syntax/loc stx (morc-syntax-error "cannot set nil")))
      ((_ t   B) (syntax/loc stx (morc-syntax-error "cannot set t")))
      ((_ A   B) (syntax/loc stx (begin (set! A B) B)))))

  (define (=app3 head arg val)
    (cond ((string?    head)  (string-set! head arg val))
          ((hash-table? head) (hash-table-put! head arg val))
          ((eqv? head car@)   (set-car! arg val))
          ((eqv? head cdr@)   (set-cdr! arg (nil-to-null val)))
          (else (raise-type-error '= "string, hashtable, car, or cdr" head))))

;;; @section Conditionals

;;; @defsyntax do !!!

  (define-syntax do@
    (syntax-rules ()
      ((_)       nil)
      ((_ X ...) (begin X ...))))

  ;; and and or are same as scheme except we have to rewrite them for t/nil.

;;; @defsyntax  and !!!
;;; @defsyntaxx or  !!!

  (define-syntax and@
    (syntax-rules ()
      ((_)         nil)
      ((_ X)       t)
      ((_ A B ...) (if (nilornull? A) nil (and@ B ...)))))

  (define-syntax or@
    (syntax-rules ()
      ((_)         nil)
      ((_ X)       nil)
      ((_ A B ...) (let ((v A)) (if (nilornull? v) (or@ B ...) v)))))

;;; @defsyntax if !!!

  (define-syntax if@
    (syntax-rules ()
      ((_)                nil)
      ((_ C)              C) ;; This is questionable.
      ((_ C A)            (if (nilornull? C) nil A))
      ((_ C A B)          (if (nilornull? C) B A))
      ((_ C A REST ...)   (if (nilornull? C) (if@ REST ...) A))))

;;; @defsyntax when !!!

;;; !!! mention i defined when and unless for mzscheme, and now no longer use
;;; them.

  (define-syntax when@
    (syntax-rules ()
      ;; TODO: We could optimize for "t" and "nil" ere.
      ((_)                t)
      ((_ C)              C)
      ((_ C E)            (if (nilornull? C) nil E))
      ((_ C E0 E1 EN ...) (if (nilornull? C) nil (begin E0 E1 EN ...)))))

  ;; arc case misses ability to have multiple keys per expression in a clause.

;;; @defsyntax case !!!

  (define-syntax case@
    (syntax-rules ()
      ((_ K D0 E0 X ...)
       (case:1 (D0 E0 X ...) K ()))))

  (define-syntax case:1
    (syntax-rules ()
      ((_ ()          K (C ...)) (case K C ...))
      ((_ (E)         K (C ...)) (case:1 ()      K (C ... (else E))))
      ((_ (D E X ...) K (C ...)) (case:1 (X ...) K (C ... ((D) E))))))

;;; @section Iteration

  ;; TODO: To be nice, we should map null-to-nil any any way to access things
  ;; that might have been expressed as literals with '().  to this includes list
  ;; iterators.

  ;; convenient in some cases, but applying closures is the scheme way.
  ;; and for-next is rarely used.

;;; @defsyntax each !!!

  (define-syntax each
    (syntax-rules ()
      ((_ V       L)       (each V L nil))
      ((_ (V ...) L B ...) (morc-syntax-error "invalid identifier" (V ...)))
      ((_ V (L ...) B ...) (let ((x (L ...))) (each V x B ...)))
      ((_ V       L B ...) (begin (for-each (lambda (V) B ...)
                                            (if (string? L) (string->list L) L))
                                  nil))))

;;; @defsyntax for !!!

  (define-syntax for
    ;; Note: This is not perfectly optimal, wrt incrementing before we test,
    ;; but the difference is insignificant with Scheme's arbitrarily large
    ;; numbers.
    (syntax-rules ()
      ((_ V S E)             (for V S E nil))
      ((_ (V ...) X ...)     (morc-syntax-error "invalid identifier" (V ...)))
      ((_ V (S ...) E B ...) (let ((x (S ...))) (for V x E B ...)))
      ((_ V S (E ...) B ...) (let ((x (E ...))) (for V S x B ...)))
      ((_ V S E B ...)       (let loop ((V S))
                               (if (<= V E)
                                   (begin B ...
                                          (loop (+ 1 V)))
                                   nil)))))

;;; @defsyntax while expr *@{ body @}

  (define-syntax while
    (syntax-rules ()
      ((_ C)              (while C nil))
      ((_ C B0 B1 BN ...) (while C (begin B0 B1 BN ...)))
      ((_ C B)            (let loop ((last nil))
                            (if (nilornull? C)
                                last
                                (loop B))))))

;;; @defsyntax repeat num +@{ body @}

  (define-syntax repeat
    (syntax-rules ()
      ((_ N B0 B1 BN ...) (repeat N (begin B0 B1 BN ...)))
      ((_ N B)            (let loop ((last nil)
                                     (x N))
                            (if (< x 1)
                                last
                                (loop B (- x 1)))))))

;;; @section List Processing

;;; @defproc map func +@{ lst @}

  (define (map@ proc . lists)
    ;; TODO: Maybe rewrite to not use "reverse" except on results.
    (let do-results ((lists   lists)
                     (results '()))
      (let do-args ((pop-lists  lists)
                    (args       '())
                    (next-lists '()))
        (if (null? pop-lists)
            (do-results (reverse next-lists)
                        (cons (apply@ proc (reverse args)) results))
            (let ((this-pop-list (car pop-lists)))
              (if (null? this-pop-list)
                  (null-to-nil (reverse results))
                  (do-args (cdr pop-lists)
                           (cons (car this-pop-list) args)
                           (cons (cdr this-pop-list) next-lists))))))))

;;; @defproc  keep pred list-or-string
;;; @defprocx rem  pred list-or-string

;;; !!! note that arc doesn't say whether the equality comparison is "is" or
;;; "iso".

;;; !!! "keep" with equality is a little odd

  (define (keep pred list-or-string)
    (keeprem pred #f list-or-string))

  (define (rem pred list-or-string)
    (keeprem pred #t list-or-string))

  (define keeprem
    (let ((doit (lambda (scheme-pred lst)
                  (let loop ((result '())
                             (lst    (nil-to-null lst)))
                    (if (null? lst)
                        (reverse result)
                        (loop (if (scheme-pred (car lst))
                                  (cons (car lst) result)
                                  result)
                              (cdr lst)))))))
      (lambda (pred negate? list-or-string)
        (null-to-nil
         (let ((scheme-pred (sugar-pred pred negate?)))
           (if (string? list-or-string)
               ;; TODO: This isn't the most efficient way to do this for
               ;; strings.
               (list->string (doit scheme-pred (string->list list-or-string)))
               (doit scheme-pred list-or-string)))))))

  (define (sugar-pred pred negate?)
    (if (procedure? pred)
        (if negate?
            (lambda (x) (not (nilornull-to-false (pred x))))
            (lambda (x)      (nilornull-to-false (pred x))))
        (if negate?
            (lambda (x) (not (equal? pred x)))
            (lambda (x)      (equal? pred x)))))

;;; @defproc all !!!
;;; @defprocx some !!!
;;;
;;; !!!

  (define (all pred list-or-string)
    (if (string? list-or-string)
        ;; TODO: Do this more efficiently for strings.
        (all pred (string->list list-or-string))
        (let ((scheme-pred (sugar-pred pred #f)))
          (let loop ((lst (nil-to-null list-or-string)))
            (if (null? lst)
                t
                (if (scheme-pred (car lst))
                    (loop (cdr lst))
                    nil))))))

  (define (some pred list-or-string)
    (if (string? list-or-string)
        ;; TODO: Do this more efficiently for strings.
        (some pred (string->list list-or-string))
        (let ((scheme-pred (sugar-pred pred #f)))
          (let loop ((lst (nil-to-null list-or-string)))
            (if (null? lst)
                nil
                (if (scheme-pred (car lst))
                    t
                    (loop (cdr lst))))))))

;;; @defproc pos !!!
;;;
;;; !!! unclear when would use this, since you don't have direct access to list
;;; elements by index.  makes more sense for string functions, especially when
;;; there is efficient direct access to string elements (not necessarily the
;;; case with non-ASCII strings).

  (define (pos pred list-or-string)
    (if (string? list-or-string)
        ;; TODO: Do this more efficiently for strings.
        (pos pred (string->list list-or-string))
        (let ((scheme-pred (sugar-pred pred #f)))
          (let loop ((lst (nil-to-null list-or-string))
                     (i   0))
            (if (null? lst)
                nil
                (if (scheme-pred (car lst))
                    i
                    (loop (cdr lst) (+ 1 i))))))))

;;; @defproc trues !!!

  (define trues
    (let ((doit (lambda (scheme-pred lst)
                  (let loop ((result '())
                             (lst    (nil-to-null lst)))
                    (if (null? lst)
                        (reverse result)
                        (loop (let ((func-out (scheme-pred (car lst))))
                                (if func-out
                                    (cons (scheme-to-arc func-out) result)
                                    result))
                              (cdr lst)))))))
      (lambda (pred list-or-string)
        (null-to-nil
         (let ((scheme-pred (sugar-pred pred #f)))
           (if (string? list-or-string)
               ;; TODO: This isn't the most efficient way to do this for
               ;; strings.
               (list->string (doit scheme-pred (string->list list-or-string)))
               (doit scheme-pred list-or-string)))))))

;;; @section Input and Output

;;; @defproc  pr  !!!
;;; @defprocx prn !!!

  (define (pr . args)
    (for-each (lambda (x)
                (cond ((string? x) (display x))
                      (else        (write x))))
              args)
    nil)

  (define (prn . args)
    (apply pr args)
    (newline)
    nil)

;;; @defsyntax tostring +@{ body @}

  (define-syntax tostring
    (syntax-rules ()
      ((_)       nil)
      ((_ B ...) (let ((os (open-output-string)))
                   (parameterize ((current-output-port os))
                     B ...
                     (begin0 (get-output-string os)
                       (close-output-port os)))))))

;;; @section Misc.

;;; @defproc len x

  (define (len x)
    (cond ((string? x) (string-length x))
          ((pair?   x) (length        x))
          (else (error "cannot get the length of: " x))))

;;; @defproc sort less-than lst
;;;
;;; !!! use sort function included with plt-scheme, albeit with arguments
;;; reversed.

  (define (sort@ less-than? lst)
    (null-to-nil
     (sort (nil-to-null lst)
           (lambda (a b)
             (nilornull-to-false (less-than? a b))))))

;;; @defproc compare less-than convert

  (define (compare less-than convert)
    (lambda (a b) (less-than (convert a) (convert b))))

;;; @section Macros

  (define-syntax (%module-begin stx)
    ;; Adapted from Mzscheme "startup.s" "mzscheme-in-stx-module-begin", plus
    ;; incorporating bit of "stx-pair?" and "stx-cdr" from
    ;; "collects/syntax/stx.ss".  Thanks to Eli Barzilay for pointing me to the
    ;; fact I had to define "#%module-begin".
    (if (or (pair? stx) (and (syntax? stx) (pair? (syntax-e stx))))
        (datum->syntax-object (quote-syntax here)
                              (list* (quote-syntax #%plain-module-begin)
                                     (datum->syntax-object
                                      stx
                                      (list (quote-syntax require-for-syntax)
                                            (list 'lib "morc.ss" "morc")
                                            ;; 'morc
                                            ))
                                     (if (pair? stx)
                                         (cdr stx)
                                         (cdr (syntax-e stx))))
                              stx)
        (raise-syntax-error #f "bad syntax" stx)))

;;; @defsyntax mac name args +@{ body @}

  ;;   (define-syntax mac
  ;;     (syntax-rules ()
  ;;       ((_ NAME ARGS BODY ...) (define-macro NAME (lambda ARGS BODY ...)))))

  (define-syntax mac
    (syntax-rules ()
      ((_ NAME ARGS BODY ...) (ka (m NAME) ARGS (BODY ...)))))

  ;; TODO: Make "mac" be able to specify optional arguments.  Might have to
  ;; move the "fn" stuff into separate module and "require-for-syntax" it
  ;; (which I have verified does work).  Actually, we should be able to do it
  ;; with the "mac".

  ;;   (define-syntax mac
  ;;     (syntax-rules ()
  ;;       ((_ NAME ARGS BODY ...)
  ;;        (define-macro NAME
  ;;          (fn ARGS BODY ...)))))

  ;; TODO: !!! The body of a "mac" does not seem to be in the Arc environment,
  ;; but in some bare Scheme one.  Phase-separation problem?
  ;;
  ;; "Important: @code{define-macro} is still restricted by MzScheme's phase
  ;; separation rules. This means that a macro cannot access run-time bindings
  ;; because it is executed in the syntax expansion phase. Translating code
  ;; that involves @code{define-macro} or @code{defmacro} from an
  ;; implementation without this restriction usually implies separating macro
  ;; related functionality into a @code{begin-for-syntax} or a module (that
  ;; will be imported with @code{require-for-syntax}) and properly
  ;; distinguishing syntactic information from run-time information."
  ;;
  ;; -- "PLT MzLib Libraries Manual" version 360, Ch. 16

;;; @defproc uniq
;;;
;;; Morc implements this by simply calling MzScheme's (non-Scheme) Lisp
;;; @code{gensym}.

  (define (uniq) (gensym))

;;; @defsyntax w/uniq VARS

  (define-syntax w/uniq
    (syntax-rules ()
      ((_ (V0 VN ...) B0 BN ...) (w/uniq:2 () (V0 VN ...) (B0 BN ...)))
      ((_ V           B0 BN ...) (w/uniq:2 () (V)         (B0 BN ...)))))

  (define-syntax w/uniq:2
    (syntax-rules ()
      ((_ X () (B ...)) (let X B ...))
      ((_ (X ...) ((V0 ...) VN ...) B)
       (morc-syntax-error "w/uniq: expected identifier:" (V0 ...)))
      ((_ (X ...) (V0 VN ...) B) (w/uniq:2 ((V0 (uniq)) X ...) (VN ...) B))))

;;; @section Non-Arc Utilities

;;; @defproc  .expand  expr
;;; @defprocx .expand1 expr

  (require (lib "pretty.ss"))

  (define (.expand expr)
    (syntax-object->datum (expand expr)))

  (define (.expand1 expr)
    (syntax-object->datum (expand-once expr)))

;;; @defvar .null

  (define .null '())

;;; @section Kludge

  ;;   (define-syntax morc
  ;;     (syntax-rules ()
  ;;       ((_ 0)     (require-for-syntax (lib "lang.ss" "morc")))
  ;;       ((_ X ...) (morc-syntax-error "expected (morc 0), got:" (morc X ...)))))

;;; @section Namespace

  (provide #%datum #%top * + - / .expand .expand1 .null all alref coerce compare
           def each even expt firstn fn for in is isa iso keep keys len listtab
           mac
           maptable nil no nthcdr obj odd pop pos pr prn push quasiquote quote
           rem repeat some sqrt t table tostring trues tuples type uniq unquote
           unquote-splicing vals w/uniq while with

           ;; TODO: Redefine "read-syntax"?
           ;;
           ;; (rename read-syntax@ read-syntax)

           ;; require-for-syntax
           ;; %make-morc-namespace

           ;; morc

           (rename %app          #%app)
           (rename %module-begin #%module-begin)
           (rename <=@           <=)
           (rename <@            <)
           (rename =@            =)
           (rename >=@           >=)
           (rename >@            >)
           (rename and@          and)
           (rename apply@        apply)
           (rename car@          car)
           (rename cadr@         cadr)
           (rename case@         case)
           (rename cdr@          cdr)
           (rename cons@         cons)
           (rename do@           do)
           (rename if@           if)
           (rename let@          let)
           (rename list@         list)
           (rename map@          map)
           (rename or@           or)
           (rename sort@         sort)
           (rename string@       string)
           (rename when@         when)))

;;; @section Tests
;;;
;;; Some tests are in the file @code{test-morc.arc}, which is included in the
;;; Morc installation package.

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.1 --- 2008-08-31
;;; First release, and only intended release.
;;;
;;; @end table