Small-Lisp Ver.1.1

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

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.1.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.
	;; Version.1.1 also implements a special operator if, which is
	;; inspired by if of Paul Graham's Arc, and fn, that is
	;; the lambda expression.
	;; 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.
	(module small-lisp-ver.1.1 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) 'if)
	(eval-if (cdr 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 ()
	((_ exp env proc)
	(let ((it (null? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-apply func args env)
	(cond
	((null? func)
	(error-message args))
	((pair? func)
	(s-fn? func args env))
	(else
	(let ((head (car args)) (tail (cdr args)))
	(let ((head-of-tail (s-assoc-helper tail env car)))
	;; 基本関数の処理
	(case func
	((1st) (s-assoc-helper head env car))
	((rst) (s-assoc-helper head env cdr))
	((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))))))))
	;; lambda式の処理
	(define (s-fn? func args env)
	(if (eq? (car func) 'fn)
	(s-eval (third func)
	(pairlis->hash (cadr func) args env))
	(error-message args)))
	;; プロンプトの表示とS式の読み込み
	(define (prompt) (begin (display "SL-USER> ") (read)))
	(define *version* "Small-Lisp Ver.1.1\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (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))
	;; (define ht (make-hasheq))
	;; (hash-set! ht 'foo 3)
	;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
	;; (define ht2 (make-hasheq))
	;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
	;;
	(define (pairlis->hash x y z)
	(cond ((or (null? x) (null? y)) z)
	(else (hash-set! z (car x) (car y))
	(pairlis->hash (cdr x) (cdr y) z))))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f 'NIL)
	;; (hash-set! ht 'x '(1 2 3))
	;; (eval-if '((atom x) x (1st x)) ht) ==> 1
	;;
	(define (eval-if con env)
	(s-assoc-helper con env
	(lambda (x)
	(let ((head (car x)) (tail (cdr x)))
	(let ((eval-head (s-eval head env)))
	(cond ((null? tail) eval-head)
	((not (eq? 'NIL eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	)

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

実行例:

	/home/cametan $ ./slisp
	Small-Lisp Ver.1.1
	SL-USER> ((fn (x) (if (atom x) x (rst x))) 100)
	100
	SL-USER> ((fn (x) (if (atom x) x (rst x))) (quote (1 2 3)))
	(2 3)
	SL-USER> (bye)
	GOOD-BYE
	/home/cametan $

view raw test.lisp hosted with ❤ by GitHub