Small-Lisp Ver.1.0

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.0.ss")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements only 5 basic Lisp functions such as 1st, rst,
	;; cons, atom, and eq.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	;; 1st and rst acts like CL; that is, (1st (quote ())) => NIL,
	;; and (rst (quote ())) => NIL
	(module small-lisp-ver.1.0 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(cond ((atom? exp)
	(s-number? exp env))
	((eq? (car exp) 'quote)
	(cadr exp))
	(else (s-apply (car exp)
	(eval-args (cdr exp) env) env))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-assoc (not (pair? foo)) env))
	;; (s-eq? 1 1) ==> t
	(define (s-eq? foo bar env)
	(s-assoc (eq? foo bar) env))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ proc exp env)
	(let ((it (null? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-apply func args env)
	(if (or (pair? func) (null? func))
	(error-message args)
	(let ((head (car args)) (tail (cdr args)))
	(let ((head-of-tail (s-assoc-helper car tail env)))
	;; 基本関数の処理
	(case func
	((1st) (s-assoc-helper car head env))
	((rst) (s-assoc-helper cdr head env))
	((cons) (cons head head-of-tail))
	((atom) (s-atom? head env))
	((eq) (s-eq? head head-of-tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env)))))))
	;; プロンプトの表示とS式の読み込み
	(define (prompt) (begin (display "SL-USER> ") (read)))
	(define *version* "Small-Lisp Ver.1.0\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memq (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (s-eval exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 'T)
	(hash-set! *environment* #f 'NIL))
	)

view raw small-lisp-ver.1.0.ss hosted with ❤ by GitHub

実行例:

	cametan-laptop% ./slisp
	Small-Lisp Ver.1.0
	SL-USER> 1
	1
	SL-USER> (1st (quote (foo baz)))
	foo
	SL-USER> (rst (quote (foo baz)))
	(baz)
	SL-USER> (eq (quote (foo baz)) (quote (1 2)))
	NIL
	SL-USER> (atom (quote foo))
	T
	SL-USER> (atom (quote (1 2 3)))
	NIL
	SL-USER> (bye)
	GOOD-BYE
	cametan-laptop%

view raw test.lisp hosted with ❤ by GitHub