[S-EXP] Remove code for Common Lisp S-Exp
We dropped support for it in SWIG 4.0.0 and nobody has stepped forward to revive it in over 2 years. See #2009.
This commit is contained in:
Olly Betts
parent
11bb422bd3
commit
b7a99f22f5
4 changed files with 5 additions and 793 deletions
|
|
@ -7,6 +7,11 @@ the issue number to the end of the URL: https://github.com/swig/swig/issues/
|
|||
Version 4.1.0 (in progress)
|
||||
===========================
|
||||
|
||||
2021-05-13: olly
|
||||
[S-EXP] #2009 Remove code for Common Lisp S-Exp. We dropped
|
||||
support for it in SWIG 4.0.0 and nobody has stepped forward to
|
||||
revive it in over 2 years.
|
||||
|
||||
2021-05-13: olly
|
||||
[Pike] #2009 Remove code for Pike. We dropped support for it in
|
||||
SWIG 4.0.0 and nobody has stepped forward to revive it in over 2
|
||||
|
|
|
|||
|
|
@ -1,10 +1,8 @@
|
|||
/* File : example.i */
|
||||
%module(directors="1") example
|
||||
#ifndef SWIGSEXP
|
||||
%{
|
||||
#include "example.h"
|
||||
%}
|
||||
#endif
|
||||
|
||||
%feature("director");
|
||||
%include "example.h"
|
||||
|
|
|
|||
|
|
@ -1,389 +0,0 @@
|
|||
;;; This is experimental code that uses the s-expression
|
||||
;;; representation of a C/C++ library interface to generate Foreign
|
||||
;;; Function Interface definitions for use with Kevin Rosenberg's
|
||||
;;; UFFI.
|
||||
;;;
|
||||
;;; Written by Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(require 'port) ; from CLOCC
|
||||
(require 'uffi))
|
||||
|
||||
(in-package :cl-user)
|
||||
|
||||
;; Interaction with the SWIG binary
|
||||
|
||||
(defvar *swig-source-directory* #p"/home/mkoeppe/s/swig1.3/")
|
||||
|
||||
(defvar *swig-program* (merge-pathnames "swig" *swig-source-directory*))
|
||||
|
||||
(defun run-swig (swig-interface-file-name &key directory-search-list module
|
||||
ignore-errors c++)
|
||||
(let ((temp-file-name "/tmp/swig.lsp"))
|
||||
(let ((process
|
||||
(port:run-prog (namestring *swig-program*)
|
||||
:output t
|
||||
:args `(,@(and c++ '("-c++"))
|
||||
"-sexp"
|
||||
,@(mapcar (lambda (dir)
|
||||
(concatenate 'string
|
||||
"-I" (namestring dir)))
|
||||
directory-search-list)
|
||||
,@(and module
|
||||
`("-module" ,module))
|
||||
"-o" ,temp-file-name
|
||||
,(namestring swig-interface-file-name)))))
|
||||
#+cmu (unless (or (zerop (ext:process-exit-code process))
|
||||
ignore-errors)
|
||||
(error "Process swig exited abnormally"))
|
||||
(with-open-file (s temp-file-name)
|
||||
(read s)))))
|
||||
|
||||
;; Type system
|
||||
|
||||
(defun parse-swigtype (type-string &key start end junk-ok)
|
||||
"Parse TYPE-STRING as SWIG's internal representation of C/C++
|
||||
types. Return two values: The type description (an improper list) and
|
||||
the terminating index into TYPE-STRING."
|
||||
;; SWIG's internal representation is described in Source/Swig/stype.c
|
||||
(unless start
|
||||
(setq start 0))
|
||||
(unless end
|
||||
(setq end (length type-string)))
|
||||
(flet ((prefix-match (prefix)
|
||||
(let ((position (mismatch prefix type-string :start2 start :end2 end)))
|
||||
(or (not position)
|
||||
(= position (length prefix)))))
|
||||
(bad-type-error (reason)
|
||||
(error "Bad SWIG type (~A): ~A" reason
|
||||
(subseq type-string start end)))
|
||||
(type-char (index)
|
||||
(and (< index (length type-string))
|
||||
(char type-string index)))
|
||||
(cons-and-recurse (prefix start end)
|
||||
(multiple-value-bind (type-description index)
|
||||
(parse-swigtype type-string :start start :end end
|
||||
:junk-ok junk-ok)
|
||||
(values (cons prefix type-description)
|
||||
index))))
|
||||
(cond
|
||||
((prefix-match "p.") ; pointer
|
||||
(cons-and-recurse '* (+ start 2) end))
|
||||
((prefix-match "r.") ; C++ reference
|
||||
(cons-and-recurse '& (+ start 2) end))
|
||||
((prefix-match "a(") ; array
|
||||
(let ((closing-paren (position #\) type-string
|
||||
:start (+ start 2)
|
||||
:end end)))
|
||||
(unless closing-paren
|
||||
(bad-type-error "missing right paren"))
|
||||
(unless (eql (type-char (+ closing-paren 1)) #\.)
|
||||
(bad-type-error "missing dot"))
|
||||
(cons-and-recurse (list 'ARRAY (subseq type-string (+ start 2) closing-paren))
|
||||
(+ closing-paren 2) end)))
|
||||
((prefix-match "q(") ; qualifier (const, volatile)
|
||||
(let ((closing-paren (position #\) type-string
|
||||
:start (+ start 2)
|
||||
:end end)))
|
||||
(unless closing-paren
|
||||
(bad-type-error "missing right paren"))
|
||||
(unless (eql (type-char (+ closing-paren 1)) #\.)
|
||||
(bad-type-error "missing dot"))
|
||||
(cons-and-recurse (list 'QUALIFIER (subseq type-string (+ start 2) closing-paren))
|
||||
(+ closing-paren 2) end)))
|
||||
((prefix-match "m(") ; C++ member pointer
|
||||
(multiple-value-bind (class-type class-end-index)
|
||||
(parse-swigtype type-string :junk-ok t
|
||||
:start (+ start 2) :end end)
|
||||
(unless (eql (type-char class-end-index) #\))
|
||||
(bad-type-error "missing right paren"))
|
||||
(unless (eql (type-char (+ class-end-index 1)) #\.)
|
||||
(bad-type-error "missing dot"))
|
||||
(cons-and-recurse (list 'MEMBER-POINTER class-type)
|
||||
(+ class-end-index 2) end)))
|
||||
((prefix-match "f(") ; function
|
||||
(loop with index = (+ start 2)
|
||||
until (eql (type-char index) #\))
|
||||
collect (multiple-value-bind (arg-type arg-end-index)
|
||||
(parse-swigtype type-string :junk-ok t
|
||||
:start index :end end)
|
||||
(case (type-char arg-end-index)
|
||||
(#\, (setq index (+ arg-end-index 1)))
|
||||
(#\) (setq index arg-end-index))
|
||||
(otherwise (bad-type-error "comma or right paren expected")))
|
||||
arg-type)
|
||||
into arg-types
|
||||
finally (unless (eql (type-char (+ index 1)) #\.)
|
||||
(bad-type-error "missing dot"))
|
||||
(return (cons-and-recurse (cons 'FUNCTION arg-types)
|
||||
(+ index 2) end))))
|
||||
((prefix-match "v(") ;varargs
|
||||
(let ((closing-paren (position #\) type-string
|
||||
:start (+ start 2)
|
||||
:end end)))
|
||||
(unless closing-paren
|
||||
(bad-type-error "missing right paren"))
|
||||
(values (list 'VARARGS (subseq type-string (+ start 2) closing-paren))
|
||||
(+ closing-paren 1))))
|
||||
(t (let ((junk-position (position-if (lambda (char)
|
||||
(member char '(#\, #\( #\) #\.)))
|
||||
type-string
|
||||
:start start :end end)))
|
||||
(cond (junk-position ; found junk
|
||||
(unless junk-ok
|
||||
(bad-type-error "trailing junk"))
|
||||
(values (subseq type-string start junk-position)
|
||||
junk-position))
|
||||
(t
|
||||
(values (subseq type-string start end)
|
||||
end))))))))
|
||||
|
||||
(defun swigtype-function-p (swigtype)
|
||||
"Check whether SWIGTYPE designates a function. If so, the second
|
||||
value is the list of argument types, and the third value is the return
|
||||
type."
|
||||
(if (and (consp swigtype)
|
||||
(consp (first swigtype))
|
||||
(eql (first (first swigtype)) 'FUNCTION))
|
||||
(values t (rest (first swigtype)) (rest swigtype))
|
||||
(values nil nil nil)))
|
||||
|
||||
|
||||
;; UFFI
|
||||
|
||||
(defvar *uffi-definitions* '())
|
||||
|
||||
(defconstant *uffi-default-primitive-type-alist*
|
||||
'(("char" . :char)
|
||||
("unsigned char" . :unsigned-byte)
|
||||
("signed char" . :byte)
|
||||
("short" . :short)
|
||||
("signed short" . :short)
|
||||
("unsigned short" . :unsigned-short)
|
||||
("int" . :int)
|
||||
("signed int" . :int)
|
||||
("unsigned int" . :unsigned-int)
|
||||
("long" . :long)
|
||||
("signed long" . :long)
|
||||
("unsigned long" . :unsigned-long)
|
||||
("float" . :float)
|
||||
("double" . :double)
|
||||
((* . "char") . :cstring)
|
||||
((* . "void") . :pointer-void)
|
||||
("void" . :void)))
|
||||
|
||||
(defvar *uffi-primitive-type-alist* *uffi-default-primitive-type-alist*)
|
||||
|
||||
(defun uffi-type-spec (type-list)
|
||||
"Return the UFFI type spec equivalent to TYPE-LIST, or NIL if there
|
||||
is no representation."
|
||||
(let ((primitive-type-pair
|
||||
(assoc type-list *uffi-primitive-type-alist* :test 'equal)))
|
||||
(cond
|
||||
(primitive-type-pair
|
||||
(cdr primitive-type-pair))
|
||||
((and (consp type-list)
|
||||
(eql (first type-list) '*))
|
||||
(let ((base-type-spec (uffi-type-spec (rest type-list))))
|
||||
(cond
|
||||
((not base-type-spec)
|
||||
:pointer-void)
|
||||
(t
|
||||
(list '* base-type-spec)))))
|
||||
(t nil))))
|
||||
|
||||
;; Parse tree
|
||||
|
||||
(defvar *uffi-output* nil)
|
||||
|
||||
(defun emit-uffi-definition (uffi-definition)
|
||||
(format *uffi-output* "~&~S~%" uffi-definition)
|
||||
(push uffi-definition *uffi-definitions*))
|
||||
|
||||
(defun make-cl-symbol (c-identifier &key uninterned)
|
||||
(let ((name (substitute #\- #\_ (string-upcase c-identifier))))
|
||||
(if uninterned
|
||||
(make-symbol name)
|
||||
(intern name))))
|
||||
|
||||
(defvar *class-scope* '() "A stack of names of nested C++ classes.")
|
||||
|
||||
(defvar *struct-fields* '())
|
||||
|
||||
(defvar *linkage* :C "NIL or :C")
|
||||
|
||||
(defgeneric handle-node (node-type &key &allow-other-keys)
|
||||
(:documentation "Handle a node of SWIG's parse tree of a C/C++ program"))
|
||||
|
||||
(defmethod handle-node ((node-type t) &key &allow-other-keys)
|
||||
;; do nothing for unknown node types
|
||||
nil)
|
||||
|
||||
(defmethod handle-node ((node-type (eql 'cdecl)) &key name decl storage parms type &allow-other-keys)
|
||||
(let ((swigtype (parse-swigtype (concatenate 'string decl type))))
|
||||
(let ((*print-pretty* nil) ; or FUNCTION would be printed as #' by cmucl
|
||||
(*print-circle* t))
|
||||
(format *uffi-output* "~&;; C Declaration: ~A ~A ~A ~A~%;; with-parms ~W~%;; of-type ~W~%"
|
||||
storage type name decl parms swigtype))
|
||||
(multiple-value-bind (function-p arg-swigtype-list return-swigtype)
|
||||
(swigtype-function-p swigtype)
|
||||
(declare (ignore arg-swigtype-list))
|
||||
(cond
|
||||
((and (null *class-scope*) function-p
|
||||
(or (eql *linkage* :c)
|
||||
(string= storage "externc")))
|
||||
;; ordinary top-level function with C linkage
|
||||
(let ((argnum 0)
|
||||
(argname-list '()))
|
||||
(flet ((unique-argname (name)
|
||||
;; Sometimes the functions in SWIG interfaces
|
||||
;; do not have unique names. Make them unique
|
||||
;; by adding a suffix. Also avoid symbols
|
||||
;; that are specially bound.
|
||||
(unless name
|
||||
(setq name (format nil "arg~D" argnum)))
|
||||
(let ((argname (make-cl-symbol name)))
|
||||
(when (boundp argname) ;specially bound
|
||||
(setq argname (make-cl-symbol name :uninterned t)))
|
||||
(push argname argname-list)
|
||||
argname)))
|
||||
(let ((uffi-arg-list
|
||||
(mapcan (lambda (param)
|
||||
(incf argnum)
|
||||
(destructuring-bind (&key name type &allow-other-keys) param
|
||||
(let ((uffi-type (uffi-type-spec (parse-swigtype type))))
|
||||
(cond
|
||||
((not uffi-type)
|
||||
(format *uffi-output* "~&;; Warning: Cannot handle type ~S of argument `~A'~%"
|
||||
type name)
|
||||
(return-from handle-node))
|
||||
((eq uffi-type :void)
|
||||
'())
|
||||
(t
|
||||
(let ((symbol (unique-argname name)))
|
||||
(list `(,symbol ,uffi-type))))))))
|
||||
parms))
|
||||
(uffi-return-type
|
||||
(uffi-type-spec return-swigtype)))
|
||||
(unless uffi-return-type
|
||||
(format *uffi-output* "~&;; Warning: Cannot handle return type `~S'~%"
|
||||
return-swigtype)
|
||||
(return-from handle-node))
|
||||
(emit-uffi-definition `(UFFI:DEF-FUNCTION ,name ,uffi-arg-list :RETURNING ,uffi-return-type))))))
|
||||
((and (not (null *class-scope*)) (null (rest *class-scope*))
|
||||
(not function-p)) ; class/struct member (no nested structs)
|
||||
(let ((uffi-type (uffi-type-spec swigtype)))
|
||||
(unless uffi-type
|
||||
(format *uffi-output* "~&;; Warning: Cannot handle type ~S of struct field `~A'~%"
|
||||
type name)
|
||||
(return-from handle-node))
|
||||
(push `(,(make-cl-symbol name) ,uffi-type) *struct-fields*)))))))
|
||||
|
||||
(defmethod handle-node ((node-type (eql 'class)) &key name children kind &allow-other-keys)
|
||||
(format *uffi-output* "~&;; Class ~A~%" name)
|
||||
(let ((*class-scope* (cons name *class-scope*))
|
||||
(*struct-fields* '()))
|
||||
(dolist (child children)
|
||||
(apply 'handle-node child))
|
||||
(emit-uffi-definition `(,(if (string= kind "union")
|
||||
'UFFI:DEF-UNION
|
||||
'UFFI:DEF-STRUCT)
|
||||
,(make-cl-symbol name) ,@(nreverse *struct-fields*)))))
|
||||
|
||||
(defmethod handle-node ((node-type (eql 'top)) &key children &allow-other-keys)
|
||||
(dolist (child children)
|
||||
(apply 'handle-node child)))
|
||||
|
||||
(defmethod handle-node ((node-type (eql 'include)) &key name children &allow-other-keys)
|
||||
(format *uffi-output* ";; INCLUDE ~A~%" name)
|
||||
(dolist (child children)
|
||||
(apply 'handle-node child)))
|
||||
|
||||
(defmethod handle-node ((node-type (eql 'extern)) &key name children &allow-other-keys)
|
||||
(format *uffi-output* ";; EXTERN \"C\" ~A~%" name)
|
||||
(let ((*linkage* :c))
|
||||
(dolist (child children)
|
||||
(apply 'handle-node child))))
|
||||
|
||||
;;(defun compute-uffi-definitions (swig-interface)
|
||||
;; (let ((*uffi-definitions* '()))
|
||||
;; (handle-node swig-interface)
|
||||
;; *uffi-definitions*))
|
||||
|
||||
;; Test instances
|
||||
|
||||
;;; Link to SWIG itself
|
||||
|
||||
#||
|
||||
|
||||
(defparameter *c++-compiler* "g++")
|
||||
|
||||
(defun stdc++-library (&key env)
|
||||
(let ((error-output (make-string-output-stream)))
|
||||
(let ((name-output (make-string-output-stream)))
|
||||
(let ((proc (ext:run-program
|
||||
*c++-compiler*
|
||||
'("-print-file-name=libstdc++.so")
|
||||
:env env
|
||||
:input nil
|
||||
:output name-output
|
||||
:error error-output)))
|
||||
(unless proc
|
||||
(error "Could not run ~A" *c++-compiler*))
|
||||
(unless (zerop (ext:process-exit-code proc))
|
||||
(system:serve-all-events 0)
|
||||
(error "~A failed:~%~A" *c++-compiler*
|
||||
(get-output-stream-string error-output))))
|
||||
(string-right-trim '(#\Newline) (get-output-stream-string name-output)))))
|
||||
|
||||
(defvar *swig-interface* nil)
|
||||
|
||||
(defvar *swig-uffi-pathname* #p"/tmp/swig-uffi.lisp")
|
||||
|
||||
(defun link-swig ()
|
||||
(setq *swig-interface*
|
||||
(run-swig (merge-pathnames "Source/swig.i" *swig-source-directory*)
|
||||
:directory-search-list
|
||||
(list (merge-pathnames "Source/" *swig-source-directory*))
|
||||
:module "swig"
|
||||
:ignore-errors t
|
||||
:c++ t))
|
||||
(with-open-file (f *swig-uffi-pathname* :direction :output)
|
||||
(let ((*linkage* :c++)
|
||||
(*uffi-definitions* '())
|
||||
(*uffi-output* f)
|
||||
(*uffi-primitive-type-alist* *uffi-default-primitive-type-alist*))
|
||||
(apply 'handle-node *swig-interface*)))
|
||||
(compile-file *swig-uffi-pathname*)
|
||||
(alien:load-foreign (merge-pathnames "Source/libswig.a"
|
||||
*swig-source-directory*)
|
||||
:libraries (list (stdc++-library)))
|
||||
;; FIXME: UFFI stuffes a "-l" in front of the passed library names
|
||||
;; (uffi:load-foreign-library (merge-pathnames "Source/libswig.a"
|
||||
;; *swig-source-directory*)
|
||||
;; :supporting-libraries
|
||||
;; (list (stdc++-library)))
|
||||
(load (compile-file-pathname *swig-uffi-pathname*)))
|
||||
|
||||
||#
|
||||
|
||||
;;;; TODO:
|
||||
|
||||
;; * How to do type lookups? Is everything important that SWIG knows
|
||||
;; about the types written out? What to make of typemaps?
|
||||
;;
|
||||
;; * Wrapped functions should probably automatically COERCE their
|
||||
;; arguments (as of type DOUBLE-FLOAT), to make the functions more
|
||||
;; flexible?
|
||||
;;
|
||||
;; * Why are the functions created by FFI interpreted?
|
||||
;;
|
||||
;; * We can't deal with more complicated structs and C++ classes
|
||||
;; directly with the FFI; we have to emit SWIG wrappers that access
|
||||
;; those classes.
|
||||
;;
|
||||
;; * A CLOS layer where structure fields are mapped as slots. It
|
||||
;; looks like we need MOP functions to implement this.
|
||||
;;
|
||||
;; * Maybe modify SWIG so that key-value hashes are distinguished from
|
||||
;; value-value hashes.
|
||||
|
|
@ -1,402 +0,0 @@
|
|||
/* -----------------------------------------------------------------------------
|
||||
* This file is part of SWIG, which is licensed as a whole under version 3
|
||||
* (or any later version) of the GNU General Public License. Some additional
|
||||
* terms also apply to certain portions of SWIG. The full details of the SWIG
|
||||
* license and copyrights can be found in the LICENSE and COPYRIGHT files
|
||||
* included with the SWIG source code as distributed by the SWIG developers
|
||||
* and at http://www.swig.org/legal.html.
|
||||
*
|
||||
* s-exp.cxx
|
||||
*
|
||||
* A parse tree represented as Lisp s-expressions.
|
||||
* ----------------------------------------------------------------------------- */
|
||||
|
||||
#include "swigmod.h"
|
||||
#include "dohint.h"
|
||||
|
||||
static const char *usage = "\
|
||||
S-Exp Options (available with -sexp)\n\
|
||||
-typemaplang <lang> - Typemap language\n\n";
|
||||
|
||||
//static Node *view_top = 0;
|
||||
static File *out = 0;
|
||||
|
||||
class Sexp:public Language {
|
||||
int indent_level;
|
||||
DOHHash *print_circle_hash;
|
||||
int print_circle_count;
|
||||
int hanging_parens;
|
||||
bool need_whitespace;
|
||||
bool need_newline;
|
||||
|
||||
public:
|
||||
Sexp():
|
||||
indent_level(0),
|
||||
print_circle_hash(0),
|
||||
print_circle_count(0),
|
||||
hanging_parens(0),
|
||||
need_whitespace(0),
|
||||
need_newline(0) {
|
||||
}
|
||||
|
||||
virtual ~ Sexp() {
|
||||
}
|
||||
|
||||
virtual void main(int argc, char *argv[]) {
|
||||
// Add a symbol to the parser for conditional compilation
|
||||
Preprocessor_define("SWIGSEXP 1", 0);
|
||||
|
||||
SWIG_typemap_lang("sexp");
|
||||
for (int iX = 0; iX < argc; iX++) {
|
||||
if (strcmp(argv[iX], "-typemaplang") == 0) {
|
||||
Swig_mark_arg(iX);
|
||||
iX++;
|
||||
SWIG_typemap_lang(argv[iX]);
|
||||
Swig_mark_arg(iX);
|
||||
continue;
|
||||
}
|
||||
if (strcmp(argv[iX], "-help") == 0) {
|
||||
fputs(usage, stdout);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* Top of the parse tree */
|
||||
virtual int top(Node *n) {
|
||||
if (out == 0) {
|
||||
String *outfile = Getattr(n, "outfile");
|
||||
Replaceall(outfile, "_wrap.cxx", ".lisp");
|
||||
Replaceall(outfile, "_wrap.c", ".lisp");
|
||||
out = NewFile(outfile, "w", SWIG_output_files());
|
||||
if (!out) {
|
||||
FileErrorDisplay(outfile);
|
||||
SWIG_exit(EXIT_FAILURE);
|
||||
}
|
||||
}
|
||||
String *f_sink = NewString("");
|
||||
Swig_register_filebyname("header", f_sink);
|
||||
Swig_register_filebyname("wrapper", f_sink);
|
||||
Swig_register_filebyname("begin", f_sink);
|
||||
Swig_register_filebyname("runtime", f_sink);
|
||||
Swig_register_filebyname("init", f_sink);
|
||||
|
||||
Swig_banner_target_lang(out, ";;;");
|
||||
|
||||
Language::top(n);
|
||||
Printf(out, "\n");
|
||||
Printf(out, ";;; Lisp parse tree produced by SWIG\n");
|
||||
print_circle_hash = NewHash();
|
||||
print_circle_count = 0;
|
||||
hanging_parens = 0;
|
||||
need_whitespace = 0;
|
||||
need_newline = 0;
|
||||
Sexp_print_node(n);
|
||||
flush_parens();
|
||||
return SWIG_OK;
|
||||
}
|
||||
|
||||
void print_indent() {
|
||||
int i;
|
||||
for (i = 0; i < indent_level; i++) {
|
||||
Printf(out, " ");
|
||||
}
|
||||
}
|
||||
|
||||
void open_paren(const String *oper) {
|
||||
flush_parens();
|
||||
Printf(out, "(");
|
||||
if (oper)
|
||||
Printf(out, "%s ", oper);
|
||||
indent_level += 2;
|
||||
}
|
||||
|
||||
void close_paren(bool neednewline = false) {
|
||||
hanging_parens++;
|
||||
if (neednewline)
|
||||
print_lazy_whitespace();
|
||||
indent_level -= 2;
|
||||
}
|
||||
|
||||
void flush_parens() {
|
||||
int i;
|
||||
if (hanging_parens) {
|
||||
for (i = 0; i < hanging_parens; i++)
|
||||
Printf(out, ")");
|
||||
hanging_parens = 0;
|
||||
need_newline = true;
|
||||
need_whitespace = true;
|
||||
}
|
||||
if (need_newline) {
|
||||
Printf(out, "\n");
|
||||
print_indent();
|
||||
need_newline = false;
|
||||
need_whitespace = false;
|
||||
} else if (need_whitespace) {
|
||||
Printf(out, " ");
|
||||
need_whitespace = false;
|
||||
}
|
||||
}
|
||||
|
||||
void print_lazy_whitespace() {
|
||||
need_whitespace = 1;
|
||||
}
|
||||
|
||||
void print_lazy_newline() {
|
||||
need_newline = 1;
|
||||
}
|
||||
|
||||
bool internal_key_p(DOH *key) {
|
||||
return ((Cmp(key, "nodeType") == 0)
|
||||
|| (Cmp(key, "firstChild") == 0)
|
||||
|| (Cmp(key, "lastChild") == 0)
|
||||
|| (Cmp(key, "parentNode") == 0)
|
||||
|| (Cmp(key, "nextSibling") == 0)
|
||||
|| (Cmp(key, "previousSibling") == 0)
|
||||
|| (Cmp(key, "csym:nextSibling") == 0)
|
||||
|| (Cmp(key, "csym:previousSibling") == 0)
|
||||
|| (Cmp(key, "typepass:visit") == 0)
|
||||
|| (Cmp(key, "allocate:visit") == 0)
|
||||
|| (*(Char(key)) == '$'));
|
||||
}
|
||||
|
||||
bool boolean_key_p(DOH *key) {
|
||||
return ((Cmp(key, "allocate:default_constructor") == 0)
|
||||
|| (Cmp(key, "allocate:default_destructor") == 0)
|
||||
|| (Cmp(key, "allows_typedef") == 0)
|
||||
|| (Cmp(key, "feature:immutable") == 0));
|
||||
}
|
||||
|
||||
bool list_key_p(DOH *key) {
|
||||
return ((Cmp(key, "parms") == 0)
|
||||
|| (Cmp(key, "baselist") == 0));
|
||||
}
|
||||
|
||||
bool plist_key_p(DOH *key)
|
||||
// true if KEY is the name of data that is a mapping from keys to
|
||||
// values, which should be printed as a plist.
|
||||
{
|
||||
return ((Cmp(key, "typescope") == 0));
|
||||
}
|
||||
|
||||
bool maybe_plist_key_p(DOH *key) {
|
||||
return (Strncmp(key, "tmap:", 5) == 0);
|
||||
}
|
||||
|
||||
bool print_circle(DOH *obj, bool list_p)
|
||||
// We have a complex object, which might be referenced several
|
||||
// times, or even recursively. Use Lisp's reader notation for
|
||||
// circular structures (#n#, #n=).
|
||||
//
|
||||
// An object can be printed in list-mode or object-mode; LIST_P toggles.
|
||||
// return TRUE if OBJ still needs to be printed
|
||||
{
|
||||
flush_parens();
|
||||
// Following is a silly hack. It works around the limitation of
|
||||
// DOH's hash tables that only work with string keys!
|
||||
char address[32];
|
||||
sprintf(address, "%p%c", obj, list_p ? 'L' : 'O');
|
||||
DOH *placeholder = Getattr(print_circle_hash, address);
|
||||
if (placeholder) {
|
||||
Printv(out, placeholder, NIL);
|
||||
return false;
|
||||
} else {
|
||||
String *placeholder = NewStringf("#%d#", ++print_circle_count);
|
||||
Setattr(print_circle_hash, address, placeholder);
|
||||
Printf(out, "#%d=", print_circle_count);
|
||||
return true;
|
||||
}
|
||||
}
|
||||
|
||||
void Sexp_print_value_of_key(DOH *value, DOH *key) {
|
||||
if ((Cmp(key, "parms") == 0) || (Cmp(key, "wrap:parms") == 0)
|
||||
|| (Cmp(key, "kwargs") == 0) || (Cmp(key, "pattern") == 0))
|
||||
Sexp_print_parms(value);
|
||||
else if (plist_key_p(key))
|
||||
Sexp_print_plist(value);
|
||||
else if (maybe_plist_key_p(key)) {
|
||||
if (DohIsMapping(value))
|
||||
Sexp_print_plist(value);
|
||||
else
|
||||
Sexp_print_doh(value);
|
||||
} else if (list_key_p(key))
|
||||
Sexp_print_list(value);
|
||||
else if (boolean_key_p(key))
|
||||
Sexp_print_boolean(value);
|
||||
else
|
||||
Sexp_print_doh(value);
|
||||
}
|
||||
|
||||
void Sexp_print_boolean(DOH *obj) {
|
||||
flush_parens();
|
||||
/* See DOH/Doh/base.c, DohGetInt() */
|
||||
if (DohIsString(obj)) {
|
||||
if (atoi(Char(obj)) != 0)
|
||||
Printf(out, "t");
|
||||
else
|
||||
Printf(out, "nil");
|
||||
} else
|
||||
Printf(out, "nil");
|
||||
}
|
||||
|
||||
void Sexp_print_list(DOH *obj) {
|
||||
if (print_circle(obj, true)) {
|
||||
open_paren(NIL);
|
||||
for (; obj; obj = nextSibling(obj)) {
|
||||
Sexp_print_doh(obj);
|
||||
print_lazy_whitespace();
|
||||
}
|
||||
close_paren(true);
|
||||
}
|
||||
}
|
||||
|
||||
void Sexp_print_parms(DOH *obj) {
|
||||
// print it as a list of plists
|
||||
if (print_circle(obj, true)) {
|
||||
open_paren(NIL);
|
||||
for (; obj; obj = nextSibling(obj)) {
|
||||
if (DohIsMapping(obj)) {
|
||||
Iterator k;
|
||||
open_paren(NIL);
|
||||
for (k = First(obj); k.key; k = Next(k)) {
|
||||
if (!internal_key_p(k.key)) {
|
||||
DOH *value = Getattr(obj, k.key);
|
||||
Sexp_print_as_keyword(k.key);
|
||||
Sexp_print_value_of_key(value, k.key);
|
||||
print_lazy_whitespace();
|
||||
}
|
||||
}
|
||||
close_paren(true);
|
||||
} else
|
||||
Sexp_print_doh(obj);
|
||||
print_lazy_whitespace();
|
||||
}
|
||||
close_paren(true);
|
||||
}
|
||||
}
|
||||
|
||||
void Sexp_print_doh(DOH *obj) {
|
||||
flush_parens();
|
||||
if (DohIsString(obj)) {
|
||||
String *o = Str(obj);
|
||||
Replaceall(o, "\\", "\\\\");
|
||||
Replaceall(o, "\"", "\\\"");
|
||||
Printf(out, "\"%s\"", o);
|
||||
Delete(o);
|
||||
} else {
|
||||
if (print_circle(obj, false)) {
|
||||
// Dispatch type
|
||||
if (nodeType(obj)) {
|
||||
Sexp_print_node(obj);
|
||||
}
|
||||
|
||||
else if (DohIsMapping(obj)) {
|
||||
Iterator k;
|
||||
open_paren(NIL);
|
||||
for (k = First(obj); k.key; k = Next(k)) {
|
||||
if (!internal_key_p(k.key)) {
|
||||
DOH *value = Getattr(obj, k.key);
|
||||
flush_parens();
|
||||
open_paren(NIL);
|
||||
Sexp_print_doh(k.key);
|
||||
Printf(out, " . ");
|
||||
Sexp_print_value_of_key(value, k.key);
|
||||
close_paren();
|
||||
}
|
||||
}
|
||||
close_paren();
|
||||
} else if (strcmp(ObjType(obj)->objname, "List") == 0) {
|
||||
int i;
|
||||
open_paren(NIL);
|
||||
for (i = 0; i < Len(obj); i++) {
|
||||
DOH *item = Getitem(obj, i);
|
||||
Sexp_print_doh(item);
|
||||
}
|
||||
close_paren();
|
||||
} else {
|
||||
// What is it?
|
||||
Printf(out, "#<DOH %s %p>", ObjType(obj)->objname, obj);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void Sexp_print_as_keyword(const DOH *k) {
|
||||
/* Print key, replacing ":" with "-" because : is CL's package prefix */
|
||||
flush_parens();
|
||||
String *key = NewString(k);
|
||||
Replaceall(key, ":", "-");
|
||||
Replaceall(key, "_", "-");
|
||||
Printf(out, ":%s ", key);
|
||||
Delete(key);
|
||||
}
|
||||
|
||||
void Sexp_print_plist_noparens(DOH *obj) {
|
||||
/* attributes map names to objects */
|
||||
Iterator k;
|
||||
bool first;
|
||||
for (k = First(obj), first = true; k.key; k = Next(k), first = false) {
|
||||
if (!internal_key_p(k.key)) {
|
||||
DOH *value = Getattr(obj, k.key);
|
||||
flush_parens();
|
||||
if (!first) {
|
||||
Printf(out, " ");
|
||||
}
|
||||
Sexp_print_as_keyword(k.key);
|
||||
/* Print value */
|
||||
Sexp_print_value_of_key(value, k.key);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void Sexp_print_plist(DOH *obj) {
|
||||
flush_parens();
|
||||
if (print_circle(obj, true)) {
|
||||
open_paren(NIL);
|
||||
Sexp_print_plist_noparens(obj);
|
||||
close_paren();
|
||||
}
|
||||
}
|
||||
|
||||
void Sexp_print_attributes(Node *obj) {
|
||||
Sexp_print_plist_noparens(obj);
|
||||
}
|
||||
|
||||
void Sexp_print_node(Node *obj) {
|
||||
Node *cobj;
|
||||
open_paren(nodeType(obj));
|
||||
/* A node has an attribute list... */
|
||||
Sexp_print_attributes(obj);
|
||||
/* ... and child nodes. */
|
||||
cobj = firstChild(obj);
|
||||
if (cobj) {
|
||||
print_lazy_newline();
|
||||
flush_parens();
|
||||
Sexp_print_as_keyword("children");
|
||||
open_paren(NIL);
|
||||
for (; cobj; cobj = nextSibling(cobj)) {
|
||||
Sexp_print_node(cobj);
|
||||
}
|
||||
close_paren();
|
||||
}
|
||||
close_paren();
|
||||
}
|
||||
|
||||
|
||||
virtual int functionWrapper(Node *n) {
|
||||
ParmList *l = Getattr(n, "parms");
|
||||
Wrapper *f = NewWrapper();
|
||||
emit_attach_parmmaps(l, f);
|
||||
Setattr(n, "wrap:parms", l);
|
||||
DelWrapper(f);
|
||||
return SWIG_OK;
|
||||
}
|
||||
|
||||
};
|
||||
|
||||
|
||||
static Language *new_swig_sexp() {
|
||||
return new Sexp();
|
||||
}
|
||||
extern "C" Language *swig_sexp(void) {
|
||||
return new_swig_sexp();
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue