I try to understand by playing around with some code I found in MIT-Scheme documentation.
one piece of code about sc-macro-transformer:
(define-syntax let1
(sc-macro-transformer
(lambda (form env)
(let ((id (cadr form))
(init (caddr form))
(exp (cadddr form)))
`((lambda (,id)
,(make-syntactic-closure env (list id) exp))
,(make-syntactic-closure env '() init))))))
;(let1 a 1 (+ a 1))
;Value: 2
but I wonder if can I take the part of "make-syntactic-closure" from `lambda ... to the body of "let.." and the program becomes :
(define-syntax let1-error
(sc-macro-transformer
(lambda (form env)
(let ((id (cadr form))
(init (make-syntactic-closure env '() (caddr form)))
(exp (make-syntactic-closure env '(id) (cadddr form))))
;; (pp `(id:,id))
;; (pp `(init:, init))
;; (pp `(exp:, exp))
`((lambda (,id)
,exp)
,init)))))
;(let1-error a 1 (+ a 1))
;Unbound variable: a
Can someone told me why that these two program is different?
Your problem is likely with:
(make-syntactic-closure env '(id) (cadddr form)))
Compare that to the previous version.
You probably want that to be (list id) instead.
Related
I have problem with macros in my lisp interpreter writtein in JavaScript. the problem is in this code:
(define log (. console "log"))
(define (alist->object alist)
"(alist->object alist)
Function convert alist pairs to JavaScript object."
(if (pair? alist)
((. alist "toObject"))))
(define (klist->alist klist)
"(klist->alist klist)
Function convert klist in form (:foo 10 :bar 20) into alist
in form ((foo . 10) (bar . 20))."
(let iter ((klist klist) (result '()))
(if (null? klist)
result
(if (and (pair? klist) (pair? (cdr klist)) (key? (car klist)))
(begin
(log ":::" (cadr klist))
(log "data" (. (cadr klist) "data"))
(iter (cddr klist) (cons (cons (key->string (car klist)) (cadr klist)) result)))))))
(define (make-empty-object)
(alist->object '()))
(define empty-object (make-empty-object))
(define klist->object (pipe klist->alist alist->object))
;; main function that give problems
(define (make-tags expr)
(log "make-tags" expr)
`(h ,(key->string (car expr))
,(klist->object (cadr expr))
,(if (not (null? (cddr expr)))
(if (and (pair? (caddr expr)) (let ((s (caaddr expr))) (and (symbol? s) (eq? s 'list))))
`(list->array (list ,#(map make-tags (cdaddr expr))))
(caddr expr)))))
(define-macro (with-tags expr)
(make-tags expr))
I call this macro using this code:
(define (view state actions)
(with-tags (:div ()
(list (:h1 () (value (cdr (assoc 'count (. state "counter")))))
(:button (:onclick (lambda () (--> actions (down 1)))) "-")
(:button (:onclick (lambda () (--> actions (up 1)))) "+")))))
which should expand to almost the same code:
(define (view state actions)
(h "div" (make-empty-object)
(list->array (list
(h "h1" (make-empty-object) (value (cdr (assoc 'count (. state "counter")))))
(h "button" (klist->object `(:onclick ,(lambda () (--> actions (down 1))))) "-")
(h "button" (klist->object `(:onclick ,(lambda () (--> actions (up 1))))) "+")))))
This function works. I have problem with expanded code using my macro that call the main function, don't know how LIPS should behave when it find:
(:onclick (lambda () (--> actions (down 1))))
inside code and you try to process it like this:
,(klist->object (cadr expr))
Right now my lisp works that lambda is marked as data (have data flag set to true this is a hack to prevent of recursive evaluation of some code from macros) and klist->object function get lambda code as list, instead of function.
How this should work in Scheme or Common Lisp? Should klist->object get function object (lambda get evaluated) or list structure with lambda as first symbol? If second then how I sould write my function and macro to evaluate lambda should I use eval (kind of hack to me).
Sorry don't know how to test this, with more bug free LISP.
EDIT:
I've tried to apply the hint from #jkiiski in guile (because in my lisp it was not working)
;; -*- sheme -*-
(define nil '())
(define (key? symbol)
"(key? symbol)
Function check if symbol is key symbol, have colon as first character."
(and (symbol? symbol) (eq? ":" (substring (symbol->string symbol) 0 1))))
(define (key->string symbol)
"(key->string symbol)
If symbol is key it convert that to string - remove colon."
(if (key? symbol)
(substring (symbol->string symbol) 1)))
(define (pair-map fn seq-list)
"(seq-map fn list)
Function call fn argument for pairs in a list and return combined list with
values returned from function fn. It work like the map but take two items from list"
(let iter ((seq-list seq-list) (result '()))
(if (null? seq-list)
result
(if (and (pair? seq-list) (pair? (cdr seq-list)))
(let* ((first (car seq-list))
(second (cadr seq-list))
(value (fn first second)))
(if (null? value)
(iter (cddr seq-list) result)
(iter (cddr seq-list) (cons value result))))))))
(define (klist->alist klist)
"(klist->alist klist)
Function convert klist in form (:foo 10 :bar 20) into alist
in form ((foo . 10) (bar . 20))."
(pair-map (lambda (first second)
(if (key? first)
(cons (key->string first) second))) klist))
(define (h props . rest)
(display props)
(display rest)
(cons (cons 'props props) (cons (cons 'rest rest) nil)))
(define (make-tags expr)
`(h ,(key->string (car expr))
(klist->alist (list ,#(cadr expr)))
,(if (not (null? (cddr expr)))
(if (and (pair? (caddr expr)) (let ((s (caaddr expr))) (and (symbol? s) (eq? s 'list))))
`(list->array (list ,#(map make-tags (cdaddr expr))))
(caddr expr)))))
(define-macro (with-tags expr)
(make-tags expr))
(define state '((count . 10)))
(define xxx (with-tags (:div ()
(list (:h1 () (cdr (assoc 'count state)))
(:button (:onclick (lambda () (display "down"))) "-")
(:button (:onclick (lambda () (display "up"))) "+")))))
but got error:
ERROR: Unbound variable: :onclick
I've found solution for my lisp, Here is code:
(define (pair-map fn seq-list)
"(seq-map fn list)
Function call fn argument for pairs in a list and return combined list with
values returned from function fn. It work like the map but take two items from list"
(let iter ((seq-list seq-list) (result '()))
(if (null? seq-list)
result
(if (and (pair? seq-list) (pair? (cdr seq-list)))
(let* ((first (car seq-list))
(second (cadr seq-list))
(value (fn first second)))
(if (null? value)
(iter (cddr seq-list) result)
(iter (cddr seq-list) (cons value result))))))))
(define (make-tags expr)
(log "make-tags" expr)
`(h ,(key->string (car expr))
(alist->object (quasiquote
;; create alist with unquote for values and keys as strings
,#(pair-map (lambda (car cdr)
(cons (cons (key->string car) (list 'unquote cdr))))
(cadr expr))))
,(if (not (null? (cddr expr)))
(if (and (pair? (caddr expr)) (let ((s (caaddr expr))) (and (symbol? s) (eq? s 'list))))
`(list->array (list ,#(map make-tags (cdaddr expr))))
(caddr expr)))))
So in my code I'm writing some kind of meta macro I'm writing quasiquote as list that will get evaluated the same as if I use in my original code:
(klist->object `(:onclick ,(lambda () (--> actions (down 1)))))
I'm using alist->object and new function pair-map, so I can unquote the value and convert key symbol to string.
is this how it should be implemented in scheme? not sure If I need to fix my lisp or macros are working correctly there.
I am writing a simple lisp interpreter as I read Lisp in Small Pieces, but I am stuck on this error for over 2 hours now. I am defining a local genv variable but still I get this error. There must be some macro expansion thing I can't understand, I have checked the expansion using a quote, and it seems to be OK. Please if someone can shed some light it would be great. (The code works with r5rs language and guile scheme)
;; Macro to print it's given arguments line by line and end with a ------
(define-syntax println
(syntax-rules ()
((_ expr expr* ...) (begin (display expr)
(newline)
(println expr* ...)))
((_ expr) (begin (display expr) (newline)))
((_) (display "--------\n"))))
(define (evaluate expr env)
(begin (println "Evaluating" expr)
(if (not (pair? expr))
(cond ((symbol? expr) (lookup env expr))
((or (number? expr) (string? expr) (char? expr) (boolean? expr) (vector? expr)) expr)
(else (error "Cannot evaluate" expr)))
;; not atom
(case (car expr)
((quote) (cadr expr))
;; (define name expr)
((define) (update (cadr expr) (caddr expr) env))
((if) (if (evaluate (cadr expr) env)
(evaluate (caddr expr) env)
(evaluate (cadddr expr) env)))
((begin) (eprogn (cdr expr) env))
((set!) (update (cadr expr) (evaluate (caddr expr) env) env))
((lambda) (make-function (cadr expr) (cddr expr) env))
(else (invoke (evaluate (car expr) env)
(evlis (cdr expr) env)))))))
;; Evaluates all the expressions (exprs) in the given environment (env)
(define (eprogn exprs env)
(if (pair? exprs)
;; False when exprs contains just one item
(if (pair? (cdr exprs))
(begin (evaluate (car exprs) env)
(eprogn (cdr exprs) env))
(evaluate (car exprs) env))
'()))
(define (evlis exprs env)
(if (pair? exprs)
(cons (evaluate (car exprs) env)
(evlis (cdr exprs) env))
'()))
;; Makes a new applicable function, that closes the environment (env)
(define (make-function vars body env)
(lambda (vals)
(eprogn body (extend-environment env vars vals))))
(define (invoke fn args)
(if (procedure? fn)
(fn args)
(error "Not a function" fn)))
;; Environment suite
;; Helper macros for working with an environment vector
;; Returns the parent environment of (env)
(define-syntax parent-env-of
(syntax-rules ()
((parent-env-of env) (vector-ref env 0))))
;; Returns the bind-map of (env)
(define-syntax bind-map-of
(syntax-rules ()
((bind-map-of env) (vector-ref env 1))))
;; Sets the parent environment of (env)
(define-syntax set-parent-env!
(syntax-rules ()
((set-parent-env! env parent-env) (vector-set! env 0 parent-env))))
;; Sets the bind-map of (env)
(define-syntax set-bind-map!
(syntax-rules ()
((set-bind-map! env bind-map) (vector-set! env 1 bind-map))))
;; Makes a new environment with the parent env set to (parent-env)
(define (make-new-environment parent-env)
(let ((new-env (vector #f #f)))
(begin
(set-parent-env! new-env parent-env)
(set-bind-map! new-env '())
new-env)))
;; Searches for the value of (sym) in (env), raises
;; error if it can't find
(define (lookup env sym)
(if (null? env)
(error "Unbound name" sym)
(let ((val (assoc sym (bind-map-of env))))
(if (equal? val #f) (lookup (parent-env-of env) sym) (cdr val)))))
;; Create the binding update the (sym)'s value to (value) in the given (env)
(define (update sym value env)
(begin (println "Called update with env: " env "sym: " sym "value: " value)
(define new-bind-map (assoc-set! (bind-map-of env) sym value))
(set-bind-map! env new-bind-map)))
;; Extends an (env) by creating a new environment and setting the
;; bindings specified by the list of symbols (vars) and the
;; list of values (vals)
(define (extend-environment vars vals env)
(define new-env (make-new-environment env))
(update-all vars vals env))
;; Helper function
(define (update-all vars vals env)
(cond ((pair? vars) (if (not (pair? vals))
(error "More symbols than values to bind with")
(begin (update (car vars) (car vals) env)
(extend (cdr vars) (cdr vals) env))))
((null? vars) (if (not (null? vals))
(error "More values than symbols to bind with")
env))))
;; Helper macros for initializing the global env bind map
Problematic code:
;; ------------PROBLEM IN THESE MACROS------------------
(define-syntax _def-initial
(syntax-rules ()
((_def-initial name)
(update 'name 'void genv))
((_def-initial name value)
(update 'name value genv))))
(define-syntax _def-primitive
(syntax-rules ()
((_def-primitive name value arity)
(_def-initial name (lambda (args)
(if (equal? arity (length args))
(apply value args)
(error "Incorrect arity" (list 'name value))))))))
(define-syntax _fill-global-env
(syntax-rules ()
((_fill-global-env)
(begin
(println "Filling the environment")
(_def-primitive + (lambda (x y) (+ x y)) 2)
(_def-primitive - (lambda (x y) (- x y)) 2)
(_def-primitive * (lambda (x y) (* x y)) 2)
(_def-primitive / (lambda (x y) (/ x y)) 2))
)))
;; Racket and Guile SAY genv IS UNBOUND
(define get-global-environment
;; name must be `genv' coz of the above macros
(let ( (genv #f) )
(lambda ()
(if (equal? genv #f) ;; If uninitialized
(begin (set! genv (make-new-environment '()))
(println "Before filling: "genv)
(_fill-global-env)
(println "After filling: " genv)
genv)
genv))))
;; ------------------- END OF PROBLEMATIC CODE(IT SEEMS) ---------------
Continue:
;; - Start the interpreter
(define (main args)
;; Define the global environment
(define genv (get-global-environment))
(println "Global environment: " genv)
(let loop ((expr (read (current-input-port))))
(if (eof-object? expr)
(println "Done")
(begin (println (evaluate expr genv))
(loop (read (current-input-port)))))))
(main "")
Here's the error I receive from Racket (in problematic code's get-global-environment's body, not in main's body):
. . genv: undefined;
cannot reference undefined identifier
Scheme macros are hygienic. The genv you defined in get-global-environment is not the same as the genv in your _def-initial (which uses whatever genv was there when _def-initial was defined, which in this case would be the top-level one, which as you pointed out does not exist).
In order to make your macro work, you must adapt _fill-global-env, _def-primitive, and _def-initial to all take a genv parameter, so that _def-initial uses that genv instead of the top-level one.
From reading a Lisp book I remember they showed an example of an OOP-style method dispatcher based on closures:
(defun create-object ()
(let ((val 0)
(get (lambda () val))
(set (lambda (new-val) (setq val new-val)))
(inc (lambda () (setq val (+ 1 val)))))
(lambda (method)
(cond ((eq method 'get)
get)
((eq method 'set)
set)
((eq method 'inc)
inc)))))
(let ((obj (create-object)))
(funcall (obj 'set) 1)
(funcall (obj 'inc))
(funcall (obj 'get))) ;; 2
Since it's just a function with a string symbol argument, I guess code intel won't be of much help here, not completing the method names or their signatures. (Compare with a similar JavaScript object.)
Is this problem generally solved? How do you program an object system in Scheme so that an editor (like Emacs) can be more intelligent with your code?
P.S. The example may be not a valid Scheme code, but you should get the idea.
I've made some starting code for you.
It's for Emacs Lisp, but it's should be very easily portable to Scheme.
Here's your usage example:
(defun create-object ()
(lexical-let* ((val 0)
(get (lambda() val))
(set (lambda(x) (setq val x))))
(generate-dispatch-table get set)))
(setq obj (create-object))
(funcall (funcall obj 'get))
;; => 0
(funcall (funcall obj 'set) 1)
;; => 1
(funcall (funcall obj 'get))
;; => 1
(scheme-completions obj)
;; => (get set)
And here's how it's implemented:
(defmacro generate-dispatch-table (&rest members)
`(lambda (method)
(cond ,#(mapcar
(lambda (x) `((eq method ',x) ,x)) members))))
(defun collect (pred x)
(when (and x (listp x))
(let ((y (funcall pred x))
(z (append
(collect pred (car x))
(collect pred (cdr x)))))
(if y
(append (list y) z)
z))))
(defun scheme-completions (obj)
(collect
(lambda(x) (and (eq (car x) 'eq)
(eq (cadr x) 'method)
(eq (caaddr x) 'quote)
(cadr (caddr x))))
obj))
And here's a simple visual interface for completions:
(require 'helm)
(defun scheme-completions-helm ()
(interactive)
(let ((y (and
(looking-back "(funcall \\([^ ]*\\) +")
(intern-soft (match-string 1)))))
(when y
(helm :sources
`((name . "members")
(candidates . ,(scheme-completions (eval y)))
(action . (lambda(x) (insert "'" x))))))))
I'm not a Emacs user, but use DrRacket and it does have an object system and do what an IDE should do, but I know Emacs is very customizable since it uses elisp so you can make support for your own syntax both in syntax highlighting and tab-completion. So you do:
Make your own object system
Edit your Emacs editor to do what you want
Many of my colleagues use it and they fix their Emacs in such ways.
Another thing, this question makes me think about the resources at schemewiki.org on the subject where the different approaches are mentioned and even a similar code to the one you posted is posted as example. It's a good read.
I would avoid double notion of symbols in create-object via an obarray.
Furthermore, the interface of the object are all functions. Therefore, use fset and avoid the double funcall.
(defun create-object ()
(lexical-let (val
(_oa (make-vector 11 0)))
(fset (intern "get" _oa) (lambda () val))
(fset (intern "inc" _oa) (lambda () (incf val)))
(fset (intern "set" _oa) (lambda (new-val) (setq val new-val)))
(lambda (method &rest args)
(apply 'funcall (intern (symbol-name method) _oa) args))))
(fset 'obj1 (create-object))
(fset 'obj2 (create-object))
(obj1 'set 1)
(obj2 'set 2)
(obj1 'inc)
(obj2 'inc)
(obj2 'inc)
(obj2 'get)
(obj1 'get)
Example for inheritance:
(defun create-object ()
(lexical-let (val
(_oa (make-vector 11 0)))
(fset (intern "get" _oa) (lambda () val))
(fset (intern "inc" _oa) (lambda () (incf val)))
(fset (intern "set" _oa) (lambda (new-val) (setq val new-val)))
(lambda (method &rest args)
(apply 'funcall (or (intern-soft (symbol-name method) _oa)
(error "Undefined function: %s" method))
args))))
(defun create-object-add10 ()
(lexical-let ((base (create-object))
(_oa (make-vector 11 0)))
(fset (intern "inc" _oa) (lambda () (funcall base 'set (+ (funcall base 'get) 10))))
(lambda (method &rest args)
(let ((call (intern-soft (symbol-name method) _oa)))
(if call
(apply 'funcall call args)
(apply 'funcall base method args))))))
(fset 'obj1 (create-object))
(fset 'obj2 (create-object-add10))
(obj1 'set 1)
(obj2 'set 2)
(obj1 'inc)
(obj2 'inc)
(obj2 'inc)
(obj2 'get)
(obj1 'get)
The definition of create-object-like methods should additionally be supported through macros. That is not done here.
For more features, note, there is a CLOS-compatible object oriented system in emacs:
https://www.gnu.org/software/emacs/manual/html_node/eieio/index.html
How can I write a calculator to prefix notation, when it should count this example '(+ * 3 2 - 2 1), where there are no brackets between characters? When I have the brackets, I can handle it, but in this case I am lost.
A quick search on google yielded this wikipedia page, with an implementation (in pseudocode) of prefix evaluation using a stack. It's a starting point for writing your own implementation. Also notice that a stack can be easily implemented using Lisp's linked lists, simply add/remove elements at the head.
I'm a beginner in scheme (excuse me if it is nasty code). This one is with the brackets:
(define (fce a)
(case a
(( + ) +)
(( - ) -)
(( * ) *)
(( / ) /)))
(define (analyze vyraz)
(if (list? vyraz)
(calcul vyraz)
vyraz))
(define (calcul vyraz)
(if (= (length vyraz) 3 )
((fce (car vyraz)) (analyze (cadr vyraz)) (analyze (caddr vyraz)))
(calcul (cons (calcul (list (car vyraz) (cadr vyraz) (caddr vyraz) (cadddr vyraz)))))))
this code can count for example this : (calcul '(- (* 3 2)(+ 1 2))
I wanted to repair this code to code without brackets but conditions and listing the original input stopped me. I do not know how to write the conditions so that I didn't lose the original input and also came the final calculation.
there are my conditions (but i think, there are at wrong syntax
(define (count vyraz)
(cond (list? vyraz)
(number? (car vyraz) (cons (car vyraz)))
(number? (cdr vyraz) (cons (cdr vyraz)))
(symbol? (cddr vyraz) (cons (cddr vyraz)))
(else (cdr vyraz) (count vyraz)))
(calcul vyraz))
Thank you for all your answers and tips :)
(define (polish-notation-eval expr)
(if (finished? expr)
(car expr)
(polish-notation-eval (the-once-over expr))))
;;either we are finished, or we need to make the-once-over to get closer to finished.
(define (the-once-over expr)
(cond ((null? expr) expr )
((well-formed-expr? expr)
(cons ((get-operator (car expr)) (cadr expr) (caddr expr))
(the-once-over (cdddr expr))))
(else (cons (car expr) (the-once-over (cdr expr))))))
;; just scrolls down the list looking for well-formed expressions to evaluate.
(define *the-operations*
(list (list '+ +)
(list '* *)
(list '- -)
(list '/ /)))
;; an association list with names and functions
(define (get-operator name)
(cadr (assoc name *the-operations*)))
;;returns the function that goes with the name
(define (finished? expr)
(= (length expr) 1))
;; we are finished one we get down to a length one list, otherwise not
(define (well-formed-expr? expr)
(and (assoc (car expr) *the-operations*)
(number? (cadr expr))
(number? (caddr expr))))
;;are the next three elements something we can go ahead and evaluate?
I'm working on actually writing something on my own in Common Lisp for once, implementing the Shunting-yard Algorithm. I thought it went okay, even if it came out rather ugly and if I doubt its Lispy-ness, but upon testing out the function in the REPL, I get the error in the title.
The code is as follows, with the test case being (shunting-yard '(3 + 5)).
(defparameter *output-queue* nil)
(defparameter *operator-stack* nil)
(defun determine-precedence (operator)
(case operator
(('+ '-) 2)
(('* '/) 3)
('^ 4)))
(defun shunting-yard (stmt)
(loop until (null stmt) do
(let ((token (car stmt)))
(cond ((or (numberp token)
(eq token '\())
(setf *output-queue* (cons token *output-queue*)))
((mapcar #'(lambda (x) (eq token x)) '(+ - * / ^))
(let* ((token-precedence (determine-precedence token))
(stack-topmost (car *operator-stack*))
(stack-precedence (determine-precedence stack-topmost)))
(when (< token-precedence stack-precedence)
(setf *output-queue* (cons stack-topmost *output-queue*))
(setf *operator-stack* (cdr *operator-stack*)))
(setf *operator-stack* (cons token *operator-stack*))))
((eq token '\))
(loop for stack-topmost in *operator-stack*
until (eq stack-topmost '\()
do (progn
(setf *output-queue* (cons stack-topmost *output-queue*))
(setf *operator-stack* (cdr *operator-stack*)))
finally (setf *operator-stack* (cdr *operator-stack*)))))
(setf stmt (cdr stmt))))
(loop while (not (null *operator-stack*))
do (progn
(setf *output-queue* (cons (car *operator-stack*) *output-queue*))
(setf *operator-stack* (cdr *operator-stack*))))
(nreverse *output-queue*))
Is the error in the code itself (my guess) or is it in my test case?
Thanks so much in advance, this was REALLY fun to write and I can't wait to work on something else, but only after I get this working.
There are several errors:
First:
(defun determine-precedence (operator)
(case operator
(('+ '-) 2)
(('* '/) 3)
('^ 4)))
The quotes need to go. All.
Second:
(mapcar #'(lambda (x) (eq token x)) '(+ - * / ^))
Above is not doing what you think. Replace it with a call to MEMBER.
Third:
(when (< token-precedence stack-precedence)
You need to make sure that the variables are really bound to numbers.
Use something like
(check-type token-precedence number)
(check-type stack-precedence number)
before as a check.
Happy further debugging...