bang-lisp-ver.1.0.ss

;; bang-lisp is a subset of Common Lisp implementation,
;; based on the textbook, "対話によるCommon Lisp入門",
;; published from 森北出版株式会社.
;; # ISBN-10: 4627836090
;; # ISBN-13: 978-4627836099
;; Additionally, some library functions are imported from
;; Appendix B of Paul Graham's "ANSI Common Lisp".
;; # ISBN-10: 4894714337
;; # ISBN-13: 978-4894714335
;; Originally, "対話によるCommon Lisp入門" suggests to use
;; CLOS, Common Lisp Object System, to implement the subset
;; of Common Lisp; however, I do not like Object Oriented
;; Programming style; in fact, I do try that by using PLT
;; Scheme's define-struct. Therefore, this implementation
;; heavily depends on PLT Scheme in order to convert some OOP
;; idea to structures with some fun and ,also, headache.
;; Thanks to PLT to provide such a great Scheme implementation,
;; anyway.
;; People may see the topic like Scheme implemented on Scheme or
;; CL implemented on CL; however I think it must be rarely to see
;; CL implemented on Scheme and vice versa. Thus, even though this
;; is my personal lesson to understand Lisps more, it may be helpful
;; for the people, studying to implement a Common Lisp subset on
;; Scheme. It must be fun across Lisp-1 and Lisp-2, with PLT.
;; By the way, most of ! mark on this source does not related to
;; any destructive operations(some are yes, of course).
;; The way of naming procedures here just relies on the text book,
;; "対話によるCommon Lisp入門".

(module bang-lisp-ver.1.0 scheme

  (provide (all-defined-out))

;;; !Lisp 基本設定

  ;; id の設定
  (define *new-id* 0)
  (define (new-id) (set! *new-id* (+ 1 *new-id*)) *new-id*)

  ;; オブジェクトの生成
  (define-struct !object (id))

  ;; 二つのオブジェクトの同値性判定
  (define (!eq? x y) (= (!object-id x) (!object-id y)))

;;; 構造体によるデータ抽象 

  ;; 構造体によるアトムの定義
  (define-struct (!atom !object) ()
    )

  ;; 構造体によるコンスの定義
  (define-struct (!cons !object)
    (first rest)
    )

  ;; 構造体による数値の定義
  (define-struct (!number !atom) (number)
    )

  ;; 構造体による文字列の定義
  (define-struct (!string !atom) (string)
    )

  ;; 構造体によるシンボルの定義
  (define-struct (!symbol !atom)
    (name value function plist package)
    #:mutable
    )

  ;; 構造体による NULL の定義
  (define-struct (!null !symbol) ()
    )

;;; 構造体によるパッケージの定義
  (define-struct (!package !atom)
    (name hash)
    )

;;; 構造体による関数の定義
  (define-struct (!function !atom) ()
    )

  ;; 構造体による特殊オペレータの定義
  (define-struct (!special !function)
    (code)
    )

  ;; 構造体による funcallable の定義
  (define-struct (!funcallable !function) ()
    )

  ;; 構造体によるプリミティヴの定義
  (define-struct (!primitive !funcallable)
    (code)
    )

  ;; 構造体によるクロージャの定義
  (define-struct (!closure !funcallable)
    (body parameters environment)
    )

  ;; make-instance で構造体によるデータ型の作成(ショートカット)
  (define-syntax make-instance
    (syntax-rules
	(!object !atom !cons !number !string
		 !symbol !package !special !primitive !closure)
      ((_ !object)
       (make-!object (new-id)))
      ((_ !atom)
       (make-!atom (new-id)))
      ((_ !cons x y)
       (make-!cons (new-id) x y))
      ((_ !number number)
       (make-!number (new-id) number))
      ((_ !string string)
       (make-!string (new-id) string))
      ((_ !symbol name value function plist package)
       (make-!symbol (new-id)
		     name value function plist package))
      ((_ !package name hash)
       (make-!package (new-id)
		      name hash))
      ((_ !special code)
       (make-!special (new-id) code))
      ((_ !primitive code)
       (make-!primitive (new-id) code))
      ((_ !closure body parameters environment)
       (make-!closure (new-id) body parameters environment))))

;;; データ変換

  ;; !Lisp のデータから PLT Scheme 上のデータへの変換
  (define (!CL->plt !obj)
    (cond ((!cons? !obj)
	   (cons (!CL->plt (!cons-first !obj))
		 (let ((tail (!cons-rest !obj)))
		   (if (!null? tail)
		       '()
		       (!CL->plt tail)))))
	  ((!symbol? !obj)
	   (string->symbol (!CL->plt (!symbol-name !obj))))
	  ((!string? !obj)
	   (!string-string !obj))
	  ((!number? !obj)
	   (!number-number !obj))
	  ((!object? !obj)
	   !obj)
	  (else
	   #f)))

  ;; PLT Scheme のデータから !Lisp 上のデータへの変換
  (define (plt->!CL obj)
    (cond ((pair? obj)
	   (!cons! (plt->!CL (car obj)) (plt->!CL (cdr obj))))
	  ((null? obj)
	   !nil)
	  ((symbol? obj)
	   (!intern! (plt->!CL (string-upcase (symbol->string obj)))))
	  ((string? obj)
	   (make-instance !string obj))
	  ((number? obj)
	   (make-instance !number obj))
	  (else
	   #f)))

;;; 手続き

  ;; !make-symbol! の定義
  (define (!make-symbol! !str !pac)
    (make-instance !symbol !str #f #f #f !pac))

  ;; null!? の定義
  (define (null!? !obj)
    (!eq? !obj !nil))

  ;; !intern! の定義
  (define (!intern! !str (!pac !*package*))
    (let ((str (!string-string !str))
	  (hash (!package-hash !pac)))
      (let ((!sym (hash-ref hash str #f)))
	(or !sym
	    (let ((!symbol (!make-symbol! !str !pac)))
	      (hash-set! hash str !symbol)
	      !symbol)))))

  ;; コンスの定義
  (define (!cons! x y)
    (make-instance !cons x y))

  ;; 引数を評価しない手続き
  (define (noeval-args! !args)
    (let loop ((!args !args) (acc '()))
      (if (null!? !args)
	  (reverse acc)
	  (loop (!cons-rest !args)
		(cons (!cons-first !args) acc)))))

  ;; 引数を評価する手続き
  (define (eval-args! !args local)
    (let loop ((!args !args) (acc '()))
      (if (null!? !args)
	  (reverse acc)
	  (loop (!cons-rest !args)
		(cons (!eval! (!cons-first !args) local) acc)))))

  ;; funcall の定義
  (define (!funcall! !obj . args)
    (cond
     ((!closure? !obj)
      (!eval! (!closure-body !obj)
	      (let ((h (!closure-environment !obj)))
		(for-each (lambda (key val)
			    (hash-set! h key val))
			  (!closure-parameters !obj)
			  args)
		h)))
     ((!primitive? !obj)
      (apply (!primitive-code !obj) args))
     (else
      #f)))

  ;; function の定義
  (define (!function! local !obj)
    (cond
     ((!cons? !obj)
      (make-instance !closure
		     (!cons-first (!cons-rest (!cons-rest !obj)))
		     (noeval-args! (!cons-first (!cons-rest !obj)))
		     local))
     ((!symbol? !obj)
      (!symbol-function !obj))
     (else
      #f)))

  ;; 外部ライブラリのロード用手続き
  (define (!lisp-load filename)
    (letrec ((!load
	      (lambda (p)
		(let ((x (read p)))
		  (cond ((eof-object? x)
			 (close-input-port p))
			(else
			 (!eval! (plt->!CL x))
			 (!load p)))))))
      (call-with-input-file filename !load)))

;;; 大域変数

  ;; 大域変数としてのパッケージの定義
  (define !*package*
    (make-instance !package
		   (plt->!CL "!CL-USER")
		   (make-hash)))

  ;; 大域変数としての nil の定義

  (define !nil
    (make-!null (new-id)
		(plt->!CL "NIL")
		#f
		#f
		#f
		!*package*))

  (set-!symbol-value! !nil !nil)
  (set-!symbol-plist! !nil !nil)

  ;; 大域変数としてのパッケージの定義

  (hash-set! (!package-hash !*package*) "NIL" !nil)

  ;; 大域変数としての t の定義
  (define !t (plt->!CL 't))
  (set-!symbol-value! !t !t)

  ;; 大域変数としての pi の定義
  (define !pi (plt->!CL 'pi))
  (set-!symbol-value! !pi (plt->!CL pi))

  ;; 大域変数としての lambda の定義
  (define !lambda (plt->!CL 'lambda))

;;; !Lisp 本体

  ;; REPL

  (define *version* "!Lisp Ver.1.0\n")

  (define (!lisp)
    (call/cc
     (lambda (k)
       (define (repl)
	 (print-prompt) (!print! (!eval! (!read! k))) (newline))
       (define (loop exp)
	 (loop (repl)))
       (display *version*)
       (loop (repl)))))

  (define (print-prompt)
    (display (string-append
	      (!CL->plt (!package-name !*package*))
	      "> ")))

  (define (!read! k)
    (let ((exp (read)))
      (if (and (list? exp)
	       (memq (car exp)
		     '(bye quit end exit)))
	  (k 'GOOD-BYE)
	  (plt->!CL exp))))

  (define (!print! !obj)
    (write (!CL->plt !obj))
    !obj)

  ;; eval
  (define (!eval! !obj (local (make-hasheq)))
    (cond
     ((!cons? !obj)
      (!apply! (!cons-first !obj) (!cons-rest !obj) local))
     ((!symbol? !obj)
      (let ((binding (hash-ref local !obj #f)))
	(or binding
	    (!symbol-value !obj))))
     (else
      !obj)))

  ;; apply
  (define (!apply! !obj !args local)
    (cond
     ((!funcallable? !obj)
      (apply !funcall!
	     (cons !obj (eval-args! !args local))))
     ((!special? !obj)
      (apply (!special-code !obj)
	     (cons local
		   (noeval-args! !args))))
     ((!symbol? !obj)
      (!apply! (!symbol-function !obj) !args local))
     (else
      #f)))

;;; 特殊オペレータの定義

  ;; quote の定義
  (define (!quote! local !a1) !a1)

  ;; if の定義
  (define (!if! local !condition !then !else)
    (if (null!? (!eval! !condition local))
	(!eval! !else local)
	(!eval! !then local)))

  ;; setq の定義
  (define (!setq! local !sym !form)
    (let ((!value (!eval! !form local))
	  (binding (hash-ref local !sym #f)))
      (cond (binding
	     (set! binding !value)
	     !value)
	    (else
	     (set-!symbol-value! !sym !value)
	     !value))))

  ;; defun の定義
  (define (!defun! local !name !parameters !body)
    (set-!symbol-function! !name
			   (make-instance !closure
					  !body
					  (noeval-args! !parameters)
					  local))
    !name)

;;; 基本関数の定義

  ;; eq? の定義
  (define (!eq!? !x !y)
    (if (!eq? !x !y) !t !nil))

  ;; null? の定義
  (define (!null!? !x) (!eq!? !x !nil))

  ;; atom? の定義
  (define (!atom!? !x)
    (cond ((!atom? !x) !t)
	  ((!null? !x) !t)
	  (else !nil)))

  ;; list? の定義
  (define (!list!? !x)
    (cond ((!cons? !x) !t)
	  ((!null? !x) !t)
	  (else !nil)))

  ;; + の定義
  (define (!+! . list-of-!numbers)
    (plt->!CL (apply + (map !CL->plt list-of-!numbers))))

  ;; - の定義
  (define (!-! . list-of-!numbers)
    (and (pair? list-of-!numbers)
	 (plt->!CL (apply - (map !CL->plt list-of-!numbers)))))

  ;; * の定義
  (define (!*! . list-of-!numbers)
    (plt->!CL (apply * (map !CL->plt list-of-!numbers))))

  ;; / の定義
  (define (!/! . list-of-!numbers)
    (and (pair? list-of-!numbers)
	 (plt->!CL (apply / (map !CL->plt list-of-!numbers)))))

  ;; eval の定義
  (define (!eval*! !form) (!eval! !form (make-hasheq)))

  ;; consp の定義
  (define (!cons!? !obj) (if (!cons? !obj) !t !nil))

  ;; stringp の定義
  (define (!string!? !obj) (if (!string? !obj) !t !nil))

;;; 各定義のインストール

  ;; quote のインストール
  (set-!symbol-function! (plt->!CL 'quote)
			 (make-instance !special !quote!))

  ;; if のインストール
  (set-!symbol-function! (plt->!CL 'if)
			 (make-instance !special !if!))

  ;; setq のインストール
  (set-!symbol-function! (plt->!CL 'setq)
			 (make-instance !special !setq!))

  ;; eq のインストール
  (set-!symbol-function! (plt->!CL 'eq)
			 (make-instance !primitive !eq!?))

  ;; null のインストール
  (set-!symbol-function! (plt->!CL 'null)
			 (make-instance !primitive !null!?))

  ;; atom のインストール
  (set-!symbol-function! (plt->!CL 'atom)
			 (make-instance !primitive !atom!?))

  ;; listp のインストール
  (set-!symbol-function! (plt->!CL 'listp)
			 (make-instance !primitive !list!?))

  ;; + のインストール
  (set-!symbol-function! (plt->!CL '+)
			 (make-instance !primitive !+!))

  ;; - のインストール
  (set-!symbol-function! (plt->!CL '-)
			 (make-instance !primitive !-!))

  ;; * のインストール
  (set-!symbol-function! (plt->!CL '*)
			 (make-instance !primitive !*!))

  ;; / のインストール
  (set-!symbol-function! (plt->!CL '/)
			 (make-instance !primitive !/!))

  ;; first のインストール
  (set-!symbol-function! (plt->!CL 'first)
			 (make-instance !primitive !cons-first))

  ;; rest のインストール
  (set-!symbol-function! (plt->!CL 'rest)
			 (make-instance !primitive !cons-rest))

  ;; cons のインストール
  (set-!symbol-function! (plt->!CL 'cons)
			 (make-instance !primitive !cons!))

  ;; read のインストール
  (set-!symbol-function! (plt->!CL 'read)
			 (make-instance !primitive !read!))

  ;; print のインストール
  (set-!symbol-function! (plt->!CL 'print)
			 (make-instance !primitive !print!))

  ;; symbol-name のインストール
  (set-!symbol-function! (plt->!CL 'symbol-name)
			 (make-instance !primitive !symbol-name))

  ;; symbol-value のインストール
  (set-!symbol-function! (plt->!CL 'symbol-value)
			 (make-instance !primitive !symbol-value))

  ;; symbol-function のインストール
  (set-!symbol-function! (plt->!CL 'symbol-function)
			 (make-instance !primitive !symbol-function))

  ;; symbol-plist のインストール
  (set-!symbol-function! (plt->!CL 'symbol-plist)
			 (make-instance !primitive !symbol-plist))

  ;; symbol-package のインストール
  (set-!symbol-function! (plt->!CL 'symbol-package)
			 (make-instance !primitive !symbol-package))

  ;; funcall のインストール
  (set-!symbol-function! (plt->!CL 'funcall)
			 (make-instance !primitive !funcall!))

  ;; function のインストール
  (set-!symbol-function! (plt->!CL 'function)
			 (make-instance !special !function!))

  ;; defun のインストール
  (set-!symbol-function! (plt->!CL 'defun)
			 (make-instance !special !defun!))

  ;; eval のインストール
  (set-!symbol-function! (plt->!CL 'eval)
			 (make-instance !primitive !eval*!))

  ;; consp のインストール
  (set-!symbol-function! (plt->!CL 'consp)
			 (make-instance !primitive !cons!?))

  ;; stringp のインストール
  (set-!symbol-function! (plt->!CL 'stringp)
			 (make-instance !primitive !string!?))  

  )

blisp

#!/usr/bin/env bash

mzscheme blisp.ss

blisp.blisp

(defun car (x)
  (first x))

(defun cadr (x)
  (car (cdr x)))

(defun cddr (x)
  (cdr (cdr x)))

(defun cdr (x)
  (rest x))

(defun copy-list-aux (x)
  (if (atom x)
      x
      (cons (car x)
	    (copy-list-aux (cdr x)))))

(defun copy-list (lst)
  (cons (car lst) (copy-list-aux (cdr lst))))

(defun copy-tree (tr)
  (if (atom tr)
      tr
      (cons (copy-tree (car tree))
	    (copy-tree (cdr tree)))))

(defun identity (x)
  x)

(defun mapcar (fn lst)
  (if (null lst)
      nil
      (cons (funcall fun (car lst))
	    (mapcar fun (cdr lst)))))

(defun not (x)
  (eq x nil))

(defun pair (lst)
  (if (null lst)
      nil
      (cons (cons (car lst) (cadr lst))
	    (pair (cddr lst)))))

(defun second (x)
  (cadr x))

(defun third (x)
  (car (cdr (cdr x))))

(defun 1+ (x)
  (+ x 1))

(defun 1- (x)
  (- x 1))

blisp.ss

;; mzscheme blisp.ss

#lang scheme

(require "bang-lisp-ver.1.0.ss")

(!lisp-load "blisp.blisp")

(!lisp)