Small-Lisp Ver.1.2

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

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.2.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 is?. Also it has fn, the lambda expression
	;; as a primitive.
	;; Version.1.2 has three special operators, if, = and def, which are
	;; inspired by Paul Graham's Arc. = is setf of CL. def if defun of CL.
	;; Rename some operators, because I like schemers' way better.
	;; 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.2 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) '=)
	(eval-= (cdr exp) env))
	((eq? (car exp) 'def)
	(eval-def (cdr exp) env))
	((eq? (car exp) 'quote)
	(cadr exp))
	(else (s-apply (car exp)
	(eval-args (cdr exp) env) 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))
	(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-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f '())
	;; (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? '() eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	(define (eval-= exp env)
	(let ((head (car exp)) (val (s-eval (cadr exp) env)))
	(if (atom? head)
	(begin (hash-set! env head val) val)
	(let ((key (cadr head)))
	(let ((var (s-assoc key env)))
	(case (car head)
	((car) (hash-set! env key
	(cons val (cdr var)))
	(s-assoc key env))
	((cdr) (hash-set! env key
	(cons (car var)
	(if (pair? val)
	val
	`(,val))))
	(s-assoc key env))
	(else (error-message exp))))))))
	(define (eval-def exp env)
	(let ((name (car exp))
	(args (cadr exp))
	(body (third exp)))
	(hash-set! env name `(fn ,args ,body))
	name))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-eval (not (pair? foo)) env))
	;; (s-is? 1 1) ==> t
	(define (s-is? foo bar env)
	(s-eval (eq? foo bar) env))
	(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))
	((is?) (s-is? 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.2\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (null-environment? 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 '()))
	;; (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 (null-environment? exp env)
	(let ((it (s-eval exp env)))
	(if (null? it)
	'NIL
	(capital-symbol it))))
	(define (capital-symbol exp)
	(cond ((symbol? exp)
	(string->symbol (string-upcase (symbol->string exp))))
	((list? exp)
	(map capital-symbol exp))
	(else
	exp)))
	)

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

実行例:

	/home/cametan $ ./slisp
	Small-Lisp Ver.1.2
	SL-USER> (= x (quote (1 2 3)))
	(1 2 3)
	SL-USER> x
	(1 2 3)
	SL-USER> (rst x)
	(2 3)
	SL-USER> (cons (quote a) x)
	(A 1 2 3)
	SL-USER> x
	(1 2 3)
	SL-USER> (= (car x) (quote a))
	(A 2 3)
	SL-USER> (= (cdr x) (quote (b c)))
	(A B C)
	SL-USER> (def car (lst) (1st lst))
	CAR
	SL-USER> (car x)
	A
	SL-USER> (def 2nd (lst) (car (rst lst)))
	2ND
	SL-USER> (2nd x)
	B
	SL-USER> (2nd (quote ()))
	NIL
	SL-USER> (bye)
	GOOD-BYE
	/home/cametan $

view raw test.lisp hosted with ❤ by GitHub