Formated by GeSHi
;;#!/usr/bin/clisp --ansi
;;
;; lang.lisp -- Un interprete simple para el lenguaje de ~~
;;
 
(defvar *syntax* (copy-readtable *readtable*))
(defvar *stack* nil)
(defvar *stack-aux* nil)
(defvar *dictionary* (make-hash-table))
 
 
(defmacro define-builtin (name &body code)
  `(define-symbol-macro ,name (progn ,@code nil)))
 
(defmacro with-syntax (() &body code)
  `(let ((*readtable* *syntax*)
         (*read-eval* nil))
     ,@code))
 
(defun autoinsert (form)
  (typecase form
    ((or integer string function)
     `(push ,form *stack*))
    (t
     form)))
 
(defun compile-procedure (stream ch)
  (declare (ignore ch))
  (with-syntax ()
    `(lambda ()
       ,@(mapcar #'autoinsert (read-delimited-list #\} stream )))))
 
 
(defun compile-definition (stream ch)
  (declare (ignore ch))
  (with-syntax ()
    (let* ((name (read stream))
           (body (read stream)))
      `(define-builtin ,name (funcall #',body)))))
 
(set-macro-character #\: #'compile-definition      nil *syntax*)
(set-macro-character #\{ #'compile-procedure       nil *syntax*)
(set-macro-character #\} (get-macro-character #\)) nil *syntax*)
 
 
;;; Primitives
 
(define-builtin drop
  (pop *stack*))
 
(define-builtin dup
  (push (car *stack*) *stack*))
 
(define-builtin >>
  (push (pop *stack*) *stack-aux*))
 
(define-builtin <<
  (push (pop *stack-aux*) *stack*))
 
(define-builtin ifelse
  (let* ((condi (third  *stack*))
         (true  (second *stack*))
         (false (first  *stack*)))
 
    drop drop drop
 
    (if (zerop condi)
        (funcall false)
        (funcall true))))
 
(define-builtin display
  (format t "~a~%" (pop *stack*)))
 
 
(define-builtin add
  (push (+ (pop *stack*)
           (pop *stack*))
        *stack*))
 
(define-builtin sub
  (push (- (- (pop *stack*)
              (pop *stack*)))
        *stack*))
 
(define-builtin mul
  (push (* (pop *stack*)
           (pop *stack*))
        *stack*))
 
(define-builtin div
  (push (/ (/ (pop *stack*)
              (pop *stack*)))
        *stack*))
 
(define-builtin bye
  #+clisp (ext:quit)
  #+sbcl (sb-ext:quit))
 
(define-builtin exit bye)
 
 
(defun prompt ()
  (fresh-line)
  (format t "> ")
  (with-syntax ()
    (read)))
 
 
(defun repl ()
  (let ((*stack* nil)
        (*stack-aux* nil))
    (loop for tok = (prompt) do
          (let ((result (eval tok)))
            (typecase result
              ((or integer string function)
               (eval (autoinsert result)))))
          (format t "[~{~a~^, ~}]~%" (reverse *stack*)))))
 
 
;; startup
(format t "; ~~ language implementation (020709) ~%")
(repl)
 
Parsed in 0.06136894 seconds