Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ;; 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!?))
- )
Add Comment
Please, Sign In to add comment