#lang racket
(require syntax/stx)
(require compatibility/mlist)
(provide tagged-list? get put xcons get-p-key get-p-lock
         un-syntax un-parse-list compound-procedure?)
;
; dontuse utilities
;
(define (tagged-list? exp7 tag)
  (if (pair? exp7)
      (eq? (car exp7) tag)
      #f))

(define (un-syntax obj); marker)
  (if (syntax? obj)
      (syntax-e obj)
      (begin (display "warning non syntax (")
             ;(display marker)
             (display "): ") (display obj) (newline) (newline) obj)))

(define (un-parse-list argh)
;  argh)
  (cond ((or (null? argh) (not (pair? argh)))
         (error "Not a quoted list. -- UN-PARSE-LIST" argh))
        ((syntax? (car argh))
         (if (eq? (un-syntax (car argh)) 'list)
             (cdr argh)
             (error "Not a quoted list. -- UN-PARSE-LIST" argh)))
        (else
         (if (tagged-list? argh 'list)
             (cdr argh)
             (error "Not a quoted list. -- UN-PARSE-LIST" argh)))))

(define (make-table)
  (let ((local-table (mlist '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (massoc key-1 (mcdr local-table))))
        (if subtable
            (let ((record (massoc key-2 (mcdr subtable))))
              (if record
                  (mcdr record)
                  #f))
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (massoc key-1 (mcdr local-table))))
        (if subtable
            (let ((record (massoc key-2 (mcdr subtable))))
              (if record
                  (set-mcdr! record value)
                  (set-mcdr! subtable
                            (mcons (mcons key-2 value)
                                  (mcdr subtable)))))
            (set-mcdr! local-table
                      (mcons (mlist key-1
                                  (mcons key-2 value))
                            (mcdr local-table)))))
      (values))    
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define operation-table (make-table))
; use the table for other uses too
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(put 'globals 'boudary 0)

(define (xcons arg1 arg2)
  ; only used in apply0
  (cons arg2 arg1))

(define (compound-procedure? p)
  (tagged-list? p 'procedure))

(define (get-p-key proc)
  ; keys are the first of the extra information for procedures
  (mlist-ref (list-ref proc 4) 0))
(define (get-p-lock proc)
  (mlist-ref (list-ref proc 4) 1))

;(define true #t)
;(define false #f)
;(define (true? x)
;  (if (or (eqv? x false) (eqv? x true))
;    (eqv? x true)
;    (error "Not logical (Boolean)" x)))
;
;(define (false? x)
;  (if (or (eqv? x false) (eqv? x true))
;    (eqv? x false)
;    (error "Not logical (Boolean)" x)))
(put 'parse 'is-equal-p   (list  'exp 'exp))
(put 'parse 'is-empty-p   (list  'exp))
(put 'parse 'is-less-p    (list  'exp 'exp))
(put 'parse 'is-greater-p (list  'exp 'exp))
(put 'parse 'is-list-p    (list  'exp))
(put 'parse 'is-number-p  (list  'exp))
(put 'parse 'is-string-p  (list  'exp))
(put 'parse 'is-logic-p   (list  'exp))
(put 'parse 'and      (list  'logic 'logic))
(put 'parse 'or       (list  'logic 'logic))
(put 'parse 'not      (list  'logic))
(put 'parse 'add      (list  'number 'number))
(put 'parse 'subtract (list  'number 'number))
(put 'parse 'multiply (list  'number 'number))
(put 'parse 'divide   (list  'number 'number))
(put 'parse 'concat   (list  'string 'string))
(put 'parse 'expand   (list  'string))
(put 'parse 'list1    (list  'exp))
(put 'parse 'append   (list  'list 'list))
(put 'parse 'slice    (list  'list 'number 'number))
(put 'parse 'length   (list  'list))
(put 'parse 'index    (list  'list 'number))

(put 'parse 'function (list  'list 'exp))
(put 'parse 'call     (list  'exp 'exp))
(put 'parse 'call1    (list  'exp 'exp))
(put 'parse 'call2    (list  'exp 'exp 'exp))
(put 'parse 'call3    (list  'exp 'exp 'exp 'exp))
(put 'parse 'call4    (list  'exp 'exp 'exp 'exp 'exp))
(put 'parse 'ify      (list  'exp 'exp 'exp))
(put 'parse 'thaw     (list  'list))
(put 'parse 'freeze   (list  'exp))
 (put 'parse 'state    (list  'stmseq 'list)) ; name
(put 'parse 'boundary (list  'list 'list 'exp)) ; name
(put 'parse 'sign     (list  'exp 'list 'exp)) ; name
(put 'parse 'name     (list  'exp 'exp 'exp))
(put 'parse 'export   (list  'exp 'exp))
(put 'parse 'import   (list  'exp 'exp))
(put 'parse 'suggest  (list  'exp 'exp 'exp))

(put 'parse 'is-name-p (list  'exp))
(put 'parse 'help     (list  'exp))
(put 'help 'info
     (lambda ()
(display "        Dontuse  -  a toy (modular meta-) programming language  ")(display (get 'help 'version))(newline)
(display " ^ Dontuse is kept simple by use of external configuration (NOT IMPLEMENTED, see external).")(newline)
(display " * Dynamic typing is made modular by adding types where wanted (see boundary).")(newline)
(display " * Side effects are (weakly) isolated in a sub-language (see state).")(newline)
(display " ^ The syntax is simple. It is not homoiconic.")(newline)
(newline)
(display "   Topics that help is available for: organization external lisp boundary state examples")(newline)
       (newline)
(display "   Keywords:")(newline)
(display "call   function    ify    thaw   freeze")(newline)
(display "state  boundary    export import name sign suggest")(newline)
(display "is-empty-p   is-equal-p   is-greater-p   is-less-p")(newline)
(display "list1  is-list-p   index  slice  append   length")(newline)
(display "logic  is-logic-p  and    or     not")(newline)
(display "number is-number-p add    divide multiply  subtract")(newline)
(display "string is-string-p concat expand")(newline)
       ))
(put 'help 'organization
     (lambda ()
(display "The state expression is a list of statements (an imperative sub-language).")(newline)
(display "The rest of dontuse is purely functional.")(newline)
(display "Operations that take names rather than first class values are used to organize ")(newline)
(display "the program. Dontuse has: sign boundary import export state name .")(newline)
       ))
(put 'help 'external
     (lambda ()
(display "External configuration files")(newline)
(display "logic number string  import export  suggest event")(newline)
       ))
(put 'help 'lisp
     (lambda ()
(display "Dontuse is influenced by Lisp. Dontuse exposes less of its internals so that ")(newline)
(display "the programmer can focus more on their program. Lists are one indexed. Use FREEZE ")(newline)
(display "in stead of quote (delay once). All pairs are lists. Lists self evaluate. ")(newline)
       (newline)
(display "A big improvement on the Lisp family of programming languages is to sequester ")(newline)
(display "side-effects and to enforce abstraction by providing an encapsulation mechanism. ")(newline)
(display "The different syntax is not important. Minimizing the language via externalizing ")(newline)
(display "depends on how well it is implemented.")(newline)
(newline)
(display "FREEZE and THAW work with syntax instead of dynamicly (QUOTE and EVAL). I don't know ")(newline)
(display "how well it will work.")(newline)
(display "Is FREEZE-NAME needed for symbols? How about special operations? frozen/index frozen/slice ")(newline)
(display " frozen/append frozen/is-equal-p frozen/is-name-p frozen/string->name frozen/name->string")(newline)
(newline)
(display "CALL syntax is distinct from list (instead of merging application w/ lists).")(newline)
(display "Auto-apply/call would need a FUNCTION-VALUE (DELAY-APPLY).")(newline)
(newline)
       ))
(put 'help 'boundary
     (lambda ()
(display "Boundary expressions take a list of producers (names of functions), followed by ")(newline)
(display "a list of consumers (names of functions), and an expression that the constraint ")(newline)
(display "(encapsulation / type) applies to. The values returned by producers are inside the ")(newline)
(display "boundary. Consumers take vales from the boundary (or not) and return values outside.")(newline)
       (newline)
(display "Boundary is much simpler than CLOS or MOP. We can think of boundary as limiting ")(newline)
(display "what we are allowed to do (break an implementation) or as adding a new type to the ")(newline)
(display "language.")(newline)
       ))
(put 'help 'state
     (lambda ()
(display "State expressions take a sequence of statements and initialize memory.")(newline)
(display "State expressions return their internal memory (as a property list).")(newline)
(display "To avoid label capture, each label statement starts a sub-list.")(newline)
       (newline)
(display "The statements are: LABEL <label>, JUMP <label>, LOAD <environment variable> ")(newline)
(display "<memory location>, STORE <memory location> <environment variable>, and EVENT ")(newline)
(display "<kind of event> <memory location> <extra info>")(newline)
(display "Load and store are like parameter passing. State's internal memory is like a CPU ")(newline)
(display "and the environment is like secondary storage.")(newline)
       ))
(put 'help 'examples
     (lambda ()
(display "Here are simple tests / examples. They return true an 2.")(newline)
(newline)
(display "is-logic-p logic imp true")(newline)
(display "is-number-p number imp 1")(newline)
(display "is-less-p number imp 1 number imp 2")(newline)
(display "is-greater-p number imp 2 number imp 1")(newline)
(display "is-string-p string imp \"a\"")(newline)
(display "is-string-p string imp quote")(newline)
(display "is-greater-p string imp \"two\" string imp \"one\"")(newline)
(display "is-less-p string imp \"one\" string imp \"two\"")(newline)
(display "is-list-p ()")(newline)
(display "is-list-p (number imp 1)")(newline)
(display "is-list-p append () ()")(newline)
(display "not logic imp false")(newline)
(display "and logic imp true logic imp true")(newline)
(display "or logic imp false logic imp true")(newline)
(display "is-empty-p ()")(newline)
(display "is-equal-p number imp 1 number imp 1")(newline)
(display "is-equal-p string imp \"two\" string imp \"two\"")(newline)
(display "ify logic imp true logic imp true ()")(newline)
       (newline)
(display "add number imp 1 number imp 1")(newline)
(display "subtract number imp 3 number imp 1")(newline)
(display "multiply number imp 2 number imp 1")(newline)
(display "divide number imp 2 number imp 1")(newline)
(display "suggest number imp 2 no-bounds-checking ignored-info")(newline)
(display "suggest number imp 2 comment the_first_counting_number")(newline)
(display "name a number imp 2 a")(newline)
(display "name x number imp 1 add x x")(newline)
(display "call function (x) add x x (number imp 1)")(newline)
(display "thaw freeze number imp 2")(newline)
(display "name burrito freeze add number imp 1 number imp 1 thaw burrito")(newline)
(display "name double function (x) add x x  name one number imp 1  name debug function (y) y  boundary (double) (debug)  sign pre (double debug)  call pre/debug (call pre/double (one))")(newline)
(display "name burrito freeze function (x) add x x call thaw burrito (number imp 1)")(newline)
(display "length expand string imp \"ab\"")(newline)
(display "length slice expand concat string imp \"ab\" string imp \"c\" number imp 2 number imp 3")(newline)
(display "index (string imp \"one\" number imp 2) number imp 2")(newline)
       (newline)
(display "state ((label start jump string imp \"end\") (label end)) (one number imp 1 two number imp 2 3 string imp \"three\")")(newline)
;(display "state ((label one event basic-output one)) (one number imp 1)")(newline)
(display "state ((label one event basic-input one extra event basic-output one extra)) (one number imp 1)")(newline)
       ))