mylisp.scm

(use simply)
(uses gauche.interactive srfi-1)

(define *version* "0.01")

(define *default-functions*
  (list
    '+ (lambda x (apply + x))
    '- (lambda x (apply - x))
    '* (lambda x (apply * x))
    '/ (lambda x (apply * x))
    '% (lambda x (apply modulo x))
    'cons (lambda x (apply cons x))
    'car (lambda x (apply car x))
    'cdr (lambda x (apply cdr x))
    'pr (lambda x (apply print x))
    'is (lambda x (apply ==? x))
    'nil? (lambda x (apply null? x))
    )
  )
(define *global-env* (list->hash-table-wrap *default-functions*))
(define *nil* 'my-lisp-nil-value)

; =is-nil?
; ---------------------------------------
(define (is-nil? s)
  (eq? s *nil*)
  )

; =lookup-value
; ----------------------------------------
(define (lookup-value key env)
  (let1 target-env (if (null? env) *global-env* env)
    (if (target-env '() 'exists? key)
      (target-env key)
      *nil*
      )
    )
  )

; =extend-env
; ----------------------------------------
(define (extend-env env keys values)
  (let ((base-env (if (null? env) *global-env* env))
        (new-env (make-hash-table-wrap))
        )
    (hash-table-for-each
      (base-env)
      (lambda (key value)
        (new-env key value)
        )
      )
    (dotimes (n (length keys))
      (new-env (list-ref keys n) (list-ref values n))
      )
    new-env
    )
  )

; =set-value
; -----------------------------------------
(define (set-value key value env)
  (let1 target-env (if (null? env) *global-env* env)
    (target-env key value)
    )
  )

; =interpret
; ------------------------------------------
(define (interpret s-expr env)
  (cond
    ; 式
    [(pair? s-expr)
     (let1 args (cdr s-expr)
       (case (car s-expr)
         ; ===quote
         [(quote) (first args)]
         ; ===if
         [(if)
          (if (interpret (first args) env)
            (interpret (second args) env)
            (interpret (third args) env)
            )
          ]
         ; ===fn (=lambda)
         [(fn)
          (let ((fn-args (first args))
                (fn-body (cdr args)))
            (lambda params
              (let1 new-env (extend-env env fn-args params)
                (fold (lambda (fn-s res)
                       (interpret fn-s new-env)
                       ) #f fn-body)
                )
              )
            )
          ]
         ; ===set (=define)
         [(set)
          (let1 val (interpret (second args) env)
            (set-value (first args) val env)
            val
            )
          ]
         [else
           ; 関数適用
           (let ((target (car s-expr))
                 (evaled-args (map (lambda (s) (interpret s env)) args)))
             (cond
               [(symbol? target)
                (let1 res (lookup-value target env)
                  (if (is-nil? res)
                    (error 'unknown-variable target)
                    (apply res evaled-args)
                    )
                  )
                ]
               [else
                 (apply (interpret target env) evaled-args)
                 ]
               )
             )
           ]
         )
       )
     ]
    ; シンボル
    [(symbol? s-expr)
     (let1 res (lookup-value s-expr env)
       (if (is-nil? res) (error 'unknown variable s-expr) res)
       )
     ]
    ; アトム
    [else s-expr]
    )
  )

; =meval
; --------------------------------
(define (meval s-expr)
  (interpret s-expr '())
  )

; =print-error
; ---------------------------------
(define (print-error err-obj)
  (print "#error: " (slot-ref err-obj 'message))
  )

; =version-print
; --------------------------
(define (version-print)
  (print "mylisp v." *version*)
  (exit)
  )

; =execute
; ----------------------
(define (execute s-expr)
  (guard (e (else (print-error e)))
    (meval s-expr)
    )
  )

; =command-line
; -----------------------
(define (command-line)
  (block _break
         (while #t
           (display "> ")
           (flush)
           (let1 s (read)
             (if (or (eq? s 'exit) (eof-object? s))
               (_break)
               (print (execute s))
               )
             )
           )
         )
  )

; =main
; -----------------------------------
(define (main args)
  (receive (options rest-args) (args->hash (cdr args)
                                           '(v)
                                           )

    (if (options 'v) (version-print))

    (let1 has-standard-input (char-ready? (standard-input-port))
      (cond
        [has-standard-input
          (execute (read (standard-input-port)))
          ]
        [(= 0 (length rest-args))
         (command-line)
         ]
        [else
          (set-value '*args* (cdr rest-args) '())
          (for-each execute (file->list read (first rest-args)))
          ]
        )
      )
    )
  )